Support the 6 ForgeFed roles + launch repo/deck/loom actor upon creation

src/Vervis/API.hs

@@ -99,6 +99,9 @@ import qualified Darcs.Local.Repository as D (createRepo)
 
 import Vervis.ActivityPub
 import Vervis.Actor hiding (hashLocalActor)
+import Vervis.Actor.Deck
+import Vervis.Actor.Loom
+import Vervis.Actor.Repo
 import Vervis.Cloth
 import Vervis.Darcs
 import Vervis.Data.Actor
@@ -124,7 +127,6 @@ import Vervis.Persist.Ticket
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
-import Vervis.Query
 import Vervis.Ticket
 import Vervis.Web.Delivery
 import Vervis.Web.Repo
@@ -392,7 +394,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 , actionAudience   = Audience recips [] [] [] [] []
                 , actionFulfills   = [AP.acceptObject accept]
                 , actionSpecific   = GrantActivity Grant
-                    { grantObject  = Left RoleAdmin
+                    { grantObject  = RoleAdmin
                     , grantContext = encodeRouteLocal $ renderLocalActor topicHash
                     , grantTarget  = encodeRouteHome $ PersonR recipHash
                     , grantResult  = Nothing
@@ -1010,7 +1012,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
     now <- liftIO getCurrentTime
     verifyNothingE muTarget "'target' not supported in Create PatchTracker"
 
-    (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
+    (loomID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
 
         -- Find the specified repo in DB
         _ <- getE repoID "No such repo in DB"
@@ -1097,13 +1099,21 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
             insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
 
         -- Return instructions for HTTP delivery to remote recipients
-        return (obiidCreate, deliverHttpCreate, deliverHttpGrant)
+        return (loomID, obiidCreate, deliverHttpCreate, deliverHttpGrant)
 
     -- Launch asynchronous HTTP delivery of Create and Grant
     lift $ do
         forkWorker "createPatchTrackerC: async HTTP Create delivery" deliverHttpCreate
         forkWorker "createPatchTrackerC: async HTTP Grant delivery" deliverHttpGrant
 
+    -- Spawn new Loom actor
+    success <- do
+        theater <- asksSite appTheater
+        env <- asksSite appEnv
+        liftIO $ launchActorIO theater env LocalActorLoom loomID
+    unless success $
+        error "Failed to spawn new Loom, somehow ID already in Theater"
+
     return obiid
 
     where
@@ -1162,7 +1172,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
         return action { actionSpecific = specific }
 
     insertCollab loomID obiidGrant = do
-        cid <- insert Collab
+        cid <- insert $ Collab RoleAdmin
         insert_ $ CollabTopicLoom cid loomID
         insert_ $ CollabEnable cid obiidGrant
         insert_ $ CollabRecipLocal cid pidUser
@@ -1183,7 +1193,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
             , actionFulfills =
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific = GrantActivity Grant
-                { grantObject   = Left RoleAdmin
+                { grantObject   = RoleAdmin
                 , grantContext  = encodeRouteLocal $ LoomR loomHash
                 , grantTarget   = encodeRouteHome $ PersonR adminHash
                 , grantResult  = Nothing
@@ -1269,7 +1279,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
     now <- liftIO getCurrentTime
     verifyNothingE muTarget "'target' not supported in Create Repository"
 
-    (obiid, newRepoHash, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
+    (repoID, obiid, newRepoHash, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
 
         -- Insert new repo to DB
         obiidCreate <-
@@ -1331,7 +1341,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
             insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
 
         -- Return instructions for HTTP delivery to remote recipients
-        return (obiidCreate, repoHash, deliverHttpCreate, deliverHttpGrant)
+        return (repoID, obiidCreate, repoHash, deliverHttpCreate, deliverHttpGrant)
 
     -- Insert new repo to filesystem
     lift $ createRepo newRepoHash
@@ -1341,6 +1351,14 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
         forkWorker "createRepositoryC: async HTTP Create delivery" deliverHttpCreate
         forkWorker "createRepositoryC: async HTTP Grant delivery" deliverHttpGrant
 
+    -- Spawn new Repo actor
+    success <- do
+        theater <- asksSite appTheater
+        env <- asksSite appEnv
+        liftIO $ launchActorIO theater env LocalActorRepo repoID
+    unless success $
+        error "Failed to spawn new Repo, somehow ID already in Theater"
+
     return obiid
 
     where
@@ -1359,8 +1377,6 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
             { repoVcs        = vcs
             , repoProject    = Nothing
             , repoMainBranch = "main"
-            , repoCollabUser = Nothing
-            , repoCollabAnon = Nothing
             , repoActor      = actorID
             , repoCreate     = createID
             , repoLoom       = Nothing
@@ -1392,7 +1408,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
         return action { actionSpecific = specific }
 
     insertCollab repoID grantID = do
-        collabID <- insert Collab
+        collabID <- insert $ Collab RoleAdmin
         insert_ $ CollabTopicRepo collabID repoID
         insert_ $ CollabEnable collabID grantID
         insert_ $ CollabRecipLocal collabID pidUser
@@ -1413,7 +1429,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
             , actionFulfills   =
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific   = GrantActivity Grant
-                { grantObject    = Left RoleAdmin
+                { grantObject    = RoleAdmin
                 , grantContext   = encodeRouteLocal $ RepoR repoHash
                 , grantTarget    = encodeRouteHome $ PersonR adminHash
                 , grantResult    = Nothing
@@ -1520,7 +1536,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
     now <- liftIO getCurrentTime
     verifyNothingE muTarget "'target' not supported in Create TicketTracker"
 
-    (obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
+    (deckID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
 
         -- Insert new deck to DB
         obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
@@ -1580,13 +1596,21 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
             insert_ $ InboxItemLocal (actorInbox senderActor) obiidAccept ibiidA
 
         -- Return instructions for HTTP delivery to remote recipients
-        return (obiidCreate, deliverHttpCreate, deliverHttpGrant)
+        return (jid, obiidCreate, deliverHttpCreate, deliverHttpGrant)
 
     -- Launch asynchronous HTTP delivery of Create and Grant
     lift $ do
         forkWorker "createTicketTrackerC: async HTTP Create delivery" deliverHttpCreate
         forkWorker "createTicketTrackerC: async HTTP Grant delivery" deliverHttpGrant
 
+    -- Spawn new Deck actor
+    success <- do
+        theater <- asksSite appTheater
+        env <- asksSite appEnv
+        liftIO $ launchActorIO theater env LocalActorDeck deckID
+    unless success $
+        error "Failed to spawn new Deck, somehow ID already in Theater"
+
     return obiid
     where
     parseTracker (AP.ActorDetail typ muser mname msummary) = do
@@ -1617,8 +1641,6 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
             , deckWorkflow   = wid
             , deckNextTicket = 1
             , deckWiki       = Nothing
-            , deckCollabAnon = Nothing
-            , deckCollabUser = Nothing
             , deckCreate     = obiidCreate
             }
         return (did, obid, ibid, aid, fsid)
@@ -1648,7 +1670,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
         return action { actionSpecific = specific }
 
     insertCollab did obiidGrant = do
-        cid <- insert Collab
+        cid <- insert $ Collab RoleAdmin
         insert_ $ CollabTopicDeck cid did
         insert_ $ CollabEnable cid obiidGrant
         insert_ $ CollabRecipLocal cid pidUser
@@ -1669,7 +1691,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
             , actionFulfills   =
                 [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate]
             , actionSpecific   = GrantActivity Grant
-                { grantObject    = Left RoleAdmin
+                { grantObject    = RoleAdmin
                 , grantContext   = encodeRouteLocal $ DeckR deckHash
                 , grantTarget    = encodeRouteHome $ PersonR adminHash
                 , grantResult    = Nothing
@@ -2604,7 +2626,7 @@ resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips r
                 case capID of
                     Left (capActor, _, capItem) -> return (capActor, capItem)
                     Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
-            verifyCapability capability (Left senderPersonID) resource
+            verifyCapability capability (Left senderPersonID) resource RoleTriage
 
             return (wi, actor, ticketID)
 
@@ -2819,7 +2841,7 @@ undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remo
                         case capID of
                             Left (capActor, _, capItem) -> return (capActor, capItem)
                             Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
-                    verifyCapability capability (Left senderPersonID) resource
+                    verifyCapability capability (Left senderPersonID) resource RoleTriage
                     lift updateDB
                     actorID <- do
                         maybeActor <- lift $ getLocalActorEntity actorByKey

src/Vervis/Access.hs

@@ -97,14 +97,13 @@ import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Role
 import Vervis.Persist.Actor
-import Vervis.Query
 import Vervis.Recipient
 
 data ObjectAccessStatus =
     NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed
         deriving Eq
 
-data PersonRole = Developer | User | Guest | RoleID RoleId
+data PersonRole = Developer | User | Guest
 
 {-
 data RepoAuthorization
@@ -138,12 +137,6 @@ roleHasAccess User          op = pure $ userAccess op
     userAccess ProjOpPush            = False
     userAccess ProjOpApplyPatch      = False
 roleHasAccess Guest         _  = pure False
-roleHasAccess (RoleID rlid) op =
-    fmap isJust . runMaybeT $
-        MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
-    where
-    roleHas role operation = getBy $ UniqueRoleAccess role operation
-    ancestorHas = flip getProjectRoleAncestorWithOpQ
 
 status :: Bool -> ObjectAccessStatus
 status True  = ObjectAccessAllowed
@@ -164,9 +157,8 @@ checkRepoAccess' mpid op repoID = do
         Just (Entity rid repo) -> do
             role <- do
                 case mpid of
-                    Just pid ->
+                    Just pid -> fromMaybe User <$> asCollab rid pid
-                        fromMaybe User . (<|> asUser repo) <$> asCollab rid pid
+                    Nothing -> pure Guest
-                    Nothing -> pure $ fromMaybe Guest $ asAnon repo
             status <$> roleHasAccess role op
     where
     asCollab rid pid = do
@@ -179,8 +171,6 @@ checkRepoAccess' mpid op repoID = do
                     recip E.^. CollabRecipLocalPerson E.==. E.val pid
                 E.limit 1
                 return $ topic E.^. CollabTopicRepoCollab
-    asUser = fmap RoleID . repoCollabUser
-    asAnon = fmap RoleID . repoCollabAnon
 
 checkRepoAccess
     :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
@@ -198,9 +188,8 @@ checkRepoAccess mpid op repoHash = do
         Just (Entity rid repo) -> do
             role <- do
                 case mpid of
-                    Just pid ->
+                    Just pid -> fromMaybe User <$> asCollab rid pid
-                        fromMaybe User . (<|> asUser repo) <$> asCollab rid pid
+                    Nothing -> pure Guest
-                    Nothing -> pure $ fromMaybe Guest $ asAnon repo
             status <$> roleHasAccess role op
     where
     asCollab rid pid = do
@@ -213,8 +202,6 @@ checkRepoAccess mpid op repoHash = do
                     recip E.^. CollabRecipLocalPerson E.==. E.val pid
                 E.limit 1
                 return $ topic E.^. CollabTopicRepoCollab
-    asUser = fmap RoleID . repoCollabUser
-    asAnon = fmap RoleID . repoCollabAnon
 
 checkProjectAccess
     :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
@@ -232,10 +219,8 @@ checkProjectAccess mpid op deckHash = do
         Just (Entity jid project) -> do
             role <- do
                 case mpid of
-                    Just pid ->
+                    Just pid -> fromMaybe User <$> asCollab jid pid
-                        fromMaybe User . (<|> asUser project) <$>
+                    Nothing -> pure Guest
-                            asCollab jid pid
-                    Nothing -> pure $ fromMaybe Guest $ asAnon project
             status <$> roleHasAccess role op
     where
     asCollab jid pid = do
@@ -248,5 +233,3 @@ checkProjectAccess mpid op deckHash = do
                     recip E.^. CollabRecipLocalPerson E.==. E.val pid
                 E.limit 1
                 return $ topic E.^. CollabTopicDeckCollab
-    asUser = fmap RoleID . deckCollabUser
-    asAnon = fmap RoleID . deckCollabAnon

src/Vervis/Actor/Common.hs

@@ -280,6 +280,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
                         capability
                         authorIdMsig
                         (topicResource recipKey)
+                        AP.RoleAdmin
                     return fulfillsID
 
         -- Verify the Collab isn't already validated
@@ -323,8 +324,9 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
                 -- Prepare a Grant activity and insert to my outbox
                 let inviterOrJoiner = either snd snd collab
                     isInvite = isLeft collab
-                grant@(actionGrant, _, _, _) <-
+                grant@(actionGrant, _, _, _) <- do
-                    lift $ prepareGrant isInvite inviterOrJoiner
+                    Collab role <- lift $ getJust collabID
+                    lift $ prepareGrant isInvite inviterOrJoiner role
                 let recipByKey = grantResourceLocalActor $ topicResource recipKey
                 _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
                 return (grantID, grant)
@@ -368,7 +370,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
             lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
         return (fulfillsID, Right joiner)
 
-    prepareGrant isInvite sender = do
+    prepareGrant isInvite sender role = do
         encodeRouteHome <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
 
@@ -410,7 +412,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce
                 , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                 , AP.actionFulfills   = [AP.acceptObject accept]
                 , AP.actionSpecific   = AP.GrantActivity AP.Grant
-                    { AP.grantObject    = Left AP.RoleAdmin
+                    { AP.grantObject    = role
                     , AP.grantContext   =
                         encodeRouteLocal $ renderLocalActor topicByHash
                     , AP.grantTarget    =
@@ -518,6 +520,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
                         capability
                         authorIdMsig
                         (topicResource recipKey)
+                        AP.RoleAdmin
                     return (fulfillsID, deleteRecipJoin, deleteRecip)
 
         -- Verify the Collab isn't already validated
@@ -699,12 +702,12 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
             _ -> throwE "Capability is remote i.e. definitely not by me"
 
     -- Check invite
-    targetByKey <- do
+    (role, targetByKey) <- do
         let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (resource, recipient) <- parseInvite author invite
+        (role, resource, recipient) <- parseInvite author invite
         unless (Left (topicResource topicKey) == resource) $
             throwE "Invite topic isn't me"
-        return recipient
+        return (role, recipient)
 
     -- If target is local, find it in our DB
     -- If target is remote, HTTP GET it, verify it's an actor, and store in
@@ -741,7 +744,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
             (actorID,) <$> getJust actorID
 
         -- Verify the specified capability gives relevant access
-        verifyCapability' capability authorIdMsig (topicResource topicKey)
+        verifyCapability'
+            capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
 
         -- Verify that target doesn't already have a Collab for me
         existingCollabIDs <-
@@ -773,7 +777,7 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
         lift $ for maybeInviteDB $ \ inviteDB -> do
 
             -- Insert Collab record to DB
-            insertCollab targetDB inviteDB
+            insertCollab role targetDB inviteDB
 
             -- Prepare forwarding Invite to my followers
             sieve <- do
@@ -792,8 +796,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
 
     where
 
-    insertCollab recipient inviteDB = do
+    insertCollab role recipient inviteDB = do
-        collabID <- insert Collab
+        collabID <- insert $ Collab role
         fulfillsID <- insert $ CollabFulfillsInvite collabID
         insert_ $ collabTopicCtor collabID topicKey
         case inviteDB of
@@ -872,7 +876,8 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
             (actorID,) <$> getJust actorID
 
         -- Verify the specified capability gives relevant access
-        verifyCapability' capability authorIdMsig (topicResource topicKey)
+        verifyCapability'
+            capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
 
         -- Find the collab that the member already has for me
         existingCollabIDs <-
@@ -1048,7 +1053,7 @@ topicJoin
 topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) join = do
 
     -- Check input
-    resource <- parseJoin join
+    (role, resource) <- parseJoin join
     unless (resource == Left (topicResource topicKey)) $
         throwE "Join's object isn't me, don't need this Join"
 
@@ -1101,7 +1106,7 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
                     )
                     pure
                     joinDB
-            lift $ insertCollab joinDB'
+            lift $ insertCollab role joinDB'
 
             -- Prepare forwarding Join to my followers
             sieve <- lift $ do
@@ -1120,8 +1125,8 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
 
     where
 
-    insertCollab joinDB = do
+    insertCollab role joinDB = do
-        collabID <- insert Collab
+        collabID <- insert $ Collab role
         fulfillsID <- insert $ CollabFulfillsJoin collabID
         insert_ $ collabTopicCtor collabID topicKey
         case joinDB of

src/Vervis/Actor/Deck.hs

@@ -360,6 +360,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
                 capability
                 authorIdMsig
                 (GrantResourceDeck recipDeckID)
+                AP.RoleTriage
 
         lift $ lift deleteFromDB
 

src/Vervis/Actor/Person.hs

@@ -440,7 +440,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
     -- Check input
     recipient <- do
         let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (_resource, target) <- parseInvite author invite
+        (_role, _resource, target) <- parseInvite author invite
         return target
 
     maybeNew <- withDBExcept $ do
@@ -538,7 +538,7 @@ personJoin
 personJoin now recipPersonID (Verse authorIdMsig body) join = do
 
     -- Check input
-    _resource <- parseJoin join
+    (_role, _resource) <- parseJoin join
 
     maybeJoinID <- lift $ withDB $ do
 
@@ -567,7 +567,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
     -- Check input
     target <- do
         h <- lift $ objUriAuthority <$> getActorURI authorIdMsig
-        (resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant
+        (_role, resource, recip, _mresult, _mstart, _mend) <- parseGrant h grant
         case (recip, authorIdMsig) of
             (Left (GrantRecipPerson p), Left (LocalActorPerson p', _, _))
                 | p == p' ->

src/Vervis/Actor/Person/Client.hs

@@ -130,7 +130,7 @@ clientInvite
 clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do
 
     -- Check input
-    (resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite
+    (_role, resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite
     _capID <- fromMaybeE maybeCap "No capability provided"
 
     -- If resource is remote, HTTP GET it and its managing actor, and insert to

src/Vervis/Client.hs

@@ -953,14 +953,15 @@ invite
     :: PersonId
     -> FedURI
     -> FedURI
+    -> AP.Role
     -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Invite URIMode)
-invite personID uRecipient uResource = do
+invite personID uRecipient uResource role = do
 
     theater <- asksSite appTheater
     env <- asksSite appEnv
 
-    let activity = AP.Invite (Left RoleAdmin) uRecipient uResource
+    let activity = AP.Invite role uRecipient uResource
-    (resource, recipient) <-
+    (_role, resource, recipient) <-
         runActE $ parseInvite (Left $ LocalActorPerson personID) activity
 
     -- If resource is remote, we need to get it from DB/HTTP to determine its

src/Vervis/Data/Collab.hs

@@ -117,9 +117,7 @@ unhashGrantRecipEOld resource e =
 unhashGrantRecipE resource e =
     ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
 
-verifyRole (Left AP.RoleAdmin) = pure ()
+verifyRole = pure
-verifyRole (Right _) =
-    throwE "ForgeFed Admin is the only role allowed currently"
 
 parseTopic
     :: StageRoute Env ~ Route App
@@ -168,41 +166,45 @@ parseInvite
     => Either (LocalActorBy Key) FedURI
     -> AP.Invite URIMode
     -> ActE
-        ( Either (GrantResourceBy Key) FedURI
+        ( AP.Role
+        , Either (GrantResourceBy Key) FedURI
         , Either (GrantRecipBy Key) FedURI
         )
-parseInvite sender (AP.Invite instrument object target) = do
+parseInvite sender (AP.Invite instrument object target) =
-    verifyRole instrument
+    (,,)
-    (,) <$> nameExceptT "Invite target" (parseTopic target)
+        <$> verifyRole instrument
+        <*> nameExceptT "Invite target" (parseTopic target)
         <*> nameExceptT "Invite object" (parseRecipient sender object)
 
 parseJoin
     :: StageRoute Env ~ Route App
-    => AP.Join URIMode -> ActE (Either (GrantResourceBy Key) FedURI)
+    => AP.Join URIMode
-parseJoin (AP.Join instrument object) = do
+    -> ActE (AP.Role, Either (GrantResourceBy Key) FedURI)
-    verifyRole instrument
+parseJoin (AP.Join instrument object) =
-    nameExceptT "Join object" (parseTopic object)
+    (,) <$> verifyRole instrument
+        <*> nameExceptT "Join object" (parseTopic object)
 
 parseGrant
     :: Host
     -> AP.Grant URIMode
     -> ActE
-        ( Either (GrantResourceBy Key) LocalURI
+        ( AP.Role
+        , Either (GrantResourceBy Key) LocalURI
         , Either (GrantRecipBy Key) FedURI
         , Maybe (LocalURI, Maybe Int)
         , Maybe UTCTime
         , Maybe UTCTime
         )
 parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = do
-    verifyRole object
     case allows of
         AP.Invoke -> pure ()
         _ -> throwE "Grant.allows isn't invoke"
     case deleg of
         Nothing -> pure ()
         Just _ -> throwE "Grant.delegates is specified"
-    (,,,,)
+    (,,,,,)
-        <$> parseContext context
+        <$> verifyRole object
+        <*> parseContext context
         <*> parseTarget target
         <*> pure
                 (fmap
@@ -212,9 +214,6 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
         <*> pure mstart
         <*> pure mend
     where
-    verifyRole (Left AP.RoleAdmin) = pure ()
-    verifyRole (Right _) =
-        throwE "ForgeFed Admin is the only role allowed currently"
     parseContext lu = do
         hl <- hostIsLocal h
         if hl

src/Vervis/Federation/Ticket.hs

@@ -114,7 +114,6 @@ import Vervis.Model.Ticket
 import Vervis.Path
 import Vervis.Persist.Actor
 import Vervis.Persist.Ticket
-import Vervis.Query
 import Vervis.Recipient
 import Vervis.Ticket
 import Vervis.Web.Repo

src/Vervis/Fetch.hs

@@ -100,7 +100,6 @@ import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
-import Vervis.Query
 import Vervis.Ticket
 
 data Result

src/Vervis/Handler/Client.hs

@@ -123,32 +123,35 @@ getHomeR = do
     personalOverview :: Entity Person -> Handler Html
     personalOverview (Entity pid _person) = do
         (repos, decks, looms) <- runDB $ (,,)
-            <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
+            <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
                     E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
-                    E.on $ collab E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
+                    E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
-                    E.on $ collab E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicRepoCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicRepoCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
                     E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
                     E.orderBy [E.asc $ repo E.^. RepoId]
-                    return (repo, actor)
+                    return (repo, actor, collab)
                 )
-            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do
+            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do
                     E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId
-                    E.on $ collab E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId
+                    E.on $ topic E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId
-                    E.on $ collab E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicDeckCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
                     E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
                     E.orderBy [E.asc $ deck E.^. DeckId]
-                    return (deck, actor)
+                    return (deck, actor, collab)
                 )
-            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do
+            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do
                     E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId
-                    E.on $ collab E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId
+                    E.on $ topic E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId
-                    E.on $ collab E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab
-                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicLoomCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLoomCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
                     E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
                     E.orderBy [E.asc $ loom E.^. LoomId]
-                    return (loom, actor)
+                    return (loom, actor, collab)
                 )
         hashRepo <- getEncodeKeyHashid
         hashDeck <- getEncodeKeyHashid
@@ -1163,10 +1166,13 @@ postPublishMergeR = do
             setMessage "Apply activity sent"
             redirect HomeR
 
-inviteForm = renderDivs $ (,,)
+inviteForm = renderDivs $ (,,,)
     <$> areq fedUriField "(URI) Whom to invite"                          Nothing
     <*> areq fedUriField "(URI) Resource"                                Nothing
+    <*> areq roleField   "Role"                                          Nothing
     <*> areq capField    "(URI) Grant activity to use for authorization" Nothing
+    where
+    roleField = selectField optionsEnum :: Field Handler AP.Role
 
 getPublishInviteR :: Handler Html
 getPublishInviteR = do
@@ -1184,14 +1190,14 @@ postPublishInviteR = do
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
 
-    (uRecipient, uResource, (uCap, cap)) <-
+    (uRecipient, uResource, role, (uCap, cap)) <-
         runFormPostRedirect PublishInviteR inviteForm
 
     (ep@(Entity pid _), a) <- getSender
     senderHash <- encodeKeyHashid pid
 
     result <- runExceptT $ do
-        (maybeSummary, audience, inv) <- invite pid uRecipient uResource
+        (maybeSummary, audience, inv) <- invite pid uRecipient uResource role
         (localRecips, remoteRecips, fwdHosts, action) <-
             makeServerInput (Just uCap) maybeSummary audience (AP.InviteActivity inv)
         handleViaActor pid (Just cap) localRecips remoteRecips fwdHosts action

src/Vervis/Handler/Deck.hs

@@ -412,20 +412,21 @@ getDeckCollabsR deckHash = do
         collabs <- do
             grants <-
                 getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
-            for grants $ \ (actor, ct, time) ->
+            for grants $ \ (role, actor, ct, time) ->
-                (,ct,time) <$> getPersonWidgetInfo actor
+                (,role,ct,time) <$> getPersonWidgetInfo actor
         invites <- do
             invites' <-
                 getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
-            for invites' $ \ (inviter, recip, time) -> (,,)
+            for invites' $ \ (inviter, recip, time, role) -> (,,,)
                 <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
                 <*> getPersonWidgetInfo recip
                 <*> pure time
+                <*> pure role
         joins <- do
             joins' <-
                 getTopicJoins CollabTopicDeckCollab CollabTopicDeckDeck deckID
-            for joins' $ \ (recip, time) ->
+            for joins' $ \ (recip, time, role) ->
-                (,time) <$> getPersonWidgetInfo recip
+                (,time,role) <$> getPersonWidgetInfo recip
         return (deck, actor, collabs, invites, joins)
     defaultLayout $(widgetFile "deck/collab/list")
     where
@@ -444,7 +445,7 @@ getDeckInviteR deckHash = do
 postDeckInviteR :: KeyHashid Deck -> Handler Html
 postDeckInviteR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
-    DeckInvite recipPersonID AP.RoleAdmin <-
+    DeckInvite recipPersonID role <-
         runFormPostRedirect (DeckInviteR deckHash) $ deckInviteForm deckID
 
     personEntity@(Entity personID person) <- requireAuth
@@ -456,7 +457,7 @@ postDeckInviteR deckHash = do
         (maybeSummary, audience, invite) <- do
             let uRecipient = encodeRouteHome $ PersonR recipPersonHash
                 uResource = encodeRouteHome $ DeckR deckHash
-            C.invite personID uRecipient uResource
+            C.invite personID uRecipient uResource role
         grantID <- do
             maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
             fromMaybeE maybeItem "You need to be a collaborator in the Deck to invite people"

src/Vervis/Migration.hs

@@ -2938,6 +2938,22 @@ changes hLocal ctx =
     , addEntities model_530_join
       -- 531
     , addEntities model_531_follow_request
+      -- 532
+    , removeEntity "RoleInherit"
+      -- 533
+    , removeEntity "RoleAccess"
+      -- 534
+    , removeField "Deck" "collabUser"
+      -- 535
+    , removeField "Deck" "collabAnon"
+      -- 536
+    , removeField "Repo" "collabUser"
+      -- 537
+    , removeField "Repo" "collabAnon"
+      -- 538
+    , removeEntity "Role"
+      -- 539
+    , addFieldPrimRequired "Collab" ("RoleAdmin" :: String) "role"
     ]
 
 migrateDB

src/Vervis/Model.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022
+ - Written in 2016, 2018, 2019, 2020, 2022, 2023
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -39,7 +39,7 @@ import Database.Persist.JSON
 import Development.PatchMediaType
 import Development.PatchMediaType.Persist
 import Network.FedURI
-import Web.ActivityPub (Doc, Activity)
+import Web.ActivityPub (Doc, Activity, Role)
 import Web.Text (HTML, PandocMarkdown)
 
 import Vervis.FedURI
@@ -80,11 +80,6 @@ instance Hashable MessageId where
     hashWithSalt salt = hashWithSalt salt . fromSqlKey
     hash = hash . fromSqlKey
 
--- "Vervis.Role" uses a 'HashMap' where the key type is 'ProjectRoleId'
-instance Hashable RoleId where
-    hashWithSalt salt = hashWithSalt salt . fromSqlKey
-    hash = hash . fromSqlKey
-
 instance Hashable PersonId where
     hashWithSalt salt = hashWithSalt salt . fromSqlKey
     hash = hash . fromSqlKey

src/Vervis/Model/Role.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2021 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2021, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -20,6 +21,8 @@ where
 
 import Database.Persist.TH
 
+import Web.ActivityPub (Role (..))
+
 data ProjectOperation
     = ProjOpOpenTicket
     | ProjOpAcceptTicket
@@ -37,3 +40,5 @@ data ProjectOperation
     deriving (Eq, Show, Read, Enum, Bounded)
 
 derivePersistField "ProjectOperation"
+
+derivePersistField "Role"

src/Vervis/Persist/Collab.hs

@@ -36,14 +36,18 @@ import Control.Monad.Trans.Reader
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
+import Data.List (sortOn)
 import Data.Text (Text)
 import Data.Time.Clock
 import Database.Persist.Sql
+import Optics.Core
 
 import qualified Database.Esqueleto as E
 
 import Network.FedURI
 
+import qualified Web.ActivityPub as AP
+
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
@@ -97,25 +101,28 @@ getTopicGrants
     => EntityField topic CollabId
     -> EntityField topic (Key resource)
     -> Key resource
-    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, Key topic, UTCTime)]
+    -> ReaderT SqlBackend m [(AP.Role, Either PersonId RemoteActorId, Key topic, UTCTime)]
 getTopicGrants topicCollabField topicActorField resourceID =
-    fmap (map adapt) $
+    fmap (reverse . sortOn (view _1) . map adapt) $
-    E.select $ E.from $ \ (topic `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do
+    E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do
         E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipR E.?. CollabRecipRemoteCollab
         E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab
         E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId
         E.on $ topic E.^. topicCollabField E.==. enable E.^. CollabEnableCollab
+        E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
         E.where_ $ topic E.^. topicActorField E.==. E.val resourceID
-        E.orderBy [E.asc $ enable E.^. CollabEnableId]
+        E.orderBy [E.desc $ enable E.^. CollabEnableId]
         return
-            ( recipL E.?. CollabRecipLocalPerson
+            ( collab E.^. CollabRole
+            , recipL E.?. CollabRecipLocalPerson
             , recipR E.?. CollabRecipRemoteActor
             , topic E.^. persistIdField
             , grant E.^. OutboxItemPublished
             )
     where
-    adapt (E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value ctID, E.Value time) =
+    adapt (E.Value role, E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value ctID, E.Value time) =
-        ( case (maybePersonID, maybeRemoteActorID) of
+        ( role
+        , case (maybePersonID, maybeRemoteActorID) of
             (Nothing, Nothing) -> error "No recip"
             (Just personID, Nothing) -> Left personID
             (Nothing, Just remoteActorID) -> Right remoteActorID
@@ -132,11 +139,11 @@ getTopicInvites
     => EntityField topic CollabId
     -> EntityField topic (Key resource)
     -> Key resource
-    -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime)]
+    -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime, AP.Role)]
 getTopicInvites topicCollabField topicActorField resourceID =
     fmap (map adapt) $
     E.select $ E.from $
-    \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
+    \ (topic `E.InnerJoin` collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
       `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR
       `E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor)
       `E.LeftOuterJoin` (inviterR `E.InnerJoin` activity)
@@ -150,6 +157,7 @@ getTopicInvites topicCollabField topicActorField resourceID =
         E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab
         E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsInviteCollab
         E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab
+        E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
         E.where_ $
             topic E.^. topicActorField E.==. E.val resourceID E.&&.
             E.isNothing (enable E.?. CollabEnableId)
@@ -161,9 +169,10 @@ getTopicInvites topicCollabField topicActorField resourceID =
             , activity E.?. RemoteActivityReceived
             , recipL E.?. CollabRecipLocalPerson
             , recipR E.?. CollabRecipRemoteActor
+            , collab E.^. CollabRole
             )
     where
-    adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR) =
+    adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR, E.Value role) =
         let l = case (inviterL, timeL) of
                     (Nothing, Nothing) -> Nothing
                     (Just i, Just t) -> Just (i, t)
@@ -187,6 +196,7 @@ getTopicInvites topicCollabField topicActorField resourceID =
                 (Nothing, Just remoteActorID) -> Right remoteActorID
                 (Just _, Just _) -> error "Multi recip"
             , time
+            , role
             )
 
 getTopicJoins
@@ -197,11 +207,11 @@ getTopicJoins
     => EntityField topic CollabId
     -> EntityField topic (Key resource)
     -> Key resource
-    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime)]
+    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime, AP.Role)]
 getTopicJoins topicCollabField topicActorField resourceID =
     fmap (map adapt) $
     E.select $ E.from $
-    \ (topic `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
+    \ (topic `E.InnerJoin` collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
       `E.LeftOuterJoin` (joinL `E.InnerJoin` recipL `E.InnerJoin` item)
       `E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity)
       ) -> do
@@ -213,6 +223,7 @@ getTopicJoins topicCollabField topicActorField resourceID =
         E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills
         E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsJoinCollab
         E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab
+        E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
         E.where_ $
             topic E.^. topicActorField E.==. E.val resourceID E.&&.
             E.isNothing (enable E.?. CollabEnableId)
@@ -222,9 +233,10 @@ getTopicJoins topicCollabField topicActorField resourceID =
             , item E.?. OutboxItemPublished
             , recipR E.?. CollabRecipRemoteActor
             , activity E.?. RemoteActivityReceived
+            , collab E.^. CollabRole
             )
     where
-    adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR) =
+    adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR, E.Value role) =
         let l = case (recipL, timeL) of
                     (Nothing, Nothing) -> Nothing
                     (Just r, Just t) -> Just (r, t)
@@ -235,8 +247,8 @@ getTopicJoins topicCollabField topicActorField resourceID =
                     _ -> error "Impossible"
         in  case (l, r) of
                 (Nothing, Nothing) -> error "No recip"
-                (Just (personID, time), Nothing) -> (Left personID, time)
+                (Just (personID, time), Nothing) -> (Left personID, time, role)
-                (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time)
+                (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time, role)
                 (Just _, Just _) -> error "Multi recip"
 
 verifyCapability
@@ -244,8 +256,9 @@ verifyCapability
     => (LocalActorBy Key, OutboxItemId)
     -> Either PersonId RemoteActorId
     -> GrantResourceBy Key
+    -> AP.Role
     -> ExceptT Text (ReaderT SqlBackend m) ()
-verifyCapability (capActor, capItem) actor resource = do
+verifyCapability (capActor, capItem) actor resource requiredRole = do
 
     -- Find the activity itself by URI in the DB
     nameExceptT "Capability activity not found" $
@@ -293,9 +306,10 @@ verifyCapability (capActor, capItem) actor resource = do
     unless (topic == resource) $
         throwE "Capability topic is some other local resource"
 
-    -- Since there are currently no roles, and grants allow only the "Admin"
+    -- Verify that the granted role is equal or greater than the required role
-    -- role that supports every operation, we don't need to check role access
+    Collab givenRole <- lift $ getJust collabID
-    return ()
+    unless (givenRole >= requiredRole) $
+        throwE "The granted role doesn't allow the requested operation"
 
 verifyCapability'
     :: MonadIO m
@@ -304,10 +318,11 @@ verifyCapability'
         (LocalActorBy Key, ActorId, OutboxItemId)
         (RemoteAuthor, LocalURI, Maybe ByteString)
     -> GrantResourceBy Key
+    -> AP.Role
     -> ExceptT Text (ReaderT SqlBackend m) ()
-verifyCapability' cap actor resource = do
+verifyCapability' cap actor resource role = do
     actorP <- processActor actor
-    verifyCapability cap actorP resource
+    verifyCapability cap actorP resource role
     where
     processActor = bitraverse processLocal processRemote
         where

src/Vervis/Persist/Ticket.hs

@@ -41,6 +41,8 @@ import qualified Data.List.NonEmpty as NE
 import Development.PatchMediaType
 import Yesod.Hashids
 
+import qualified Web.ActivityPub as AP
+
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
@@ -177,7 +179,7 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
         case capID of
             Left (capActor, _, capItem) -> return (capActor, capItem)
             Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
-    verifyCapability capability actor (GrantResourceLoom loomID)
+    verifyCapability capability actor (GrantResourceLoom loomID) AP.RoleWrite
 
     -- Get the patches from DB, verify VCS match just in case
     diffs <- do

src/Vervis/Query.hs

@@ -1,78 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ Copying is an act of love. Please copy, reuse and share.
- -
- - The author(s) have dedicated all copyright and related and neighboring
- - rights to this software to the public domain worldwide. This software is
- - distributed without any warranty.
- -
- - You should have received a copy of the CC0 Public Domain Dedication along
- - with this software. If not, see
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
--- | DB actions for long, complicated or unsafe queries. All the non-trivial
--- usage of raw SQL and so on goes into this module. Hopefully, this module
--- helps identify patterns and commonly needed but missing tools, which can
--- then be implemented and simplify the queries.
-module Vervis.Query
-    ( getProjectRoleAncestorWithOpQ
-    )
-where
-
-import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.Trans.Reader (ReaderT, ask)
-import Data.Maybe (listToMaybe)
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import Database.Persist
-import Database.Persist.Sql
-import Database.Persist.Sql.Util
-
-import qualified Data.Text as T (intercalate)
-
-import Database.Persist.Graph.Class
-import Database.Persist.Graph.SQL
-import Vervis.Model
-import Vervis.Model.Role
-
--- | Given a project role and a project operation, find an ancestor role which
--- has access to the operation.
-getProjectRoleAncestorWithOpQ
-    :: MonadIO m
-    => ProjectOperation
-    -> RoleId
-    -> ReaderT SqlBackend m (Maybe (Entity RoleAccess))
-getProjectRoleAncestorWithOpQ op role = do
-    conn <- ask
-    let dbname = connEscapeName conn
-        eAcc = entityDef $ dummyFromField RoleAccessId
-        tAcc = dbname $ entityDB eAcc
-        qcols =
-            T.intercalate ", " $
-            map ((tAcc <>) . ("." <>)) $
-            entityColumnNames eAcc conn
-        field :: PersistEntity record => EntityField record typ -> Text
-        field = dbname . fieldDB . persistFieldDef
-    listToMaybe <$>
-        rawSqlWithGraph
-            Ancestors
-            role
-            RoleInheritParent
-            RoleInheritChild
-            (\ temp -> mconcat
-                [ "SELECT ??"
-                , " FROM ", dbname temp, " INNER JOIN ", tAcc
-                , " ON "
-                , dbname temp, ".", field RoleInheritParent
-                , " = "
-                , tAcc, ".", field RoleAccessRole
-                , " WHERE "
-                , tAcc, ".", field RoleAccessOp
-                , " = ?"
-                , " LIMIT 1"
-                ]
-            )
-            [toPersistValue op]

src/Vervis/Role.hs

@@ -1,59 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ Copying is an act of love. Please copy, reuse and share.
- -
- - The author(s) have dedicated all copyright and related and neighboring
- - rights to this software to the public domain worldwide. This software is
- - distributed without any warranty.
- -
- - You should have received a copy of the CC0 Public Domain Dedication along
- - with this software. If not, see
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
-module Vervis.Role
-    ( getProjectRoleGraph
-    )
-where
-
-import Control.Arrow (second, (&&&), (***))
-import Data.Graph.Inductive.Graph (mkGraph)
-import Data.Graph.Inductive.PatriciaTree (Gr)
-import Data.Tuple (swap)
-import Database.Esqueleto
-import Yesod.Persist.Core (runDB)
-
-import qualified Data.HashMap.Lazy as M (fromList, lookup)
-import qualified Database.Persist as P
-
-import Vervis.Foundation
-import Vervis.Model
-import Vervis.Model.Ident
-
-getProjectRoleGraph :: SharerId -> AppDB (Gr RlIdent ())
-getProjectRoleGraph sid = do
-    (roles, inhs) <- do
-        prs <- P.selectList [RoleSharer P.==. sid] []
-        prhs <- select $ from $ \ (pr `InnerJoin` prh) -> do
-            on $ pr ^. RoleId ==. prh ^. RoleInheritParent
-            where_ $ pr ^. RoleSharer ==. val sid
-            return prh
-        return (prs, prhs)
-    let numbered = zip [1..] roles
-        nodes = map (second $ roleIdent . entityVal) numbered
-        nodeMap = M.fromList $ map (swap . second entityKey) numbered
-        pridToNode prid =
-            case M.lookup prid nodeMap of
-                Nothing -> error "Role graph: Node not found in node map"
-                Just n  -> n
-        edges =
-            map
-                ( (\ (c, p) -> (c, p, ()))
-                . (pridToNode *** pridToNode)
-                . (roleInheritChild &&& roleInheritParent)
-                . entityVal
-                )
-                inhs
-    return $ mkGraph nodes edges

src/Web/ActivityPub.hs

@@ -1518,19 +1518,31 @@ instance ActivityPub Branch where
         <> "ref"     .= ref
         <> "context" .= ObjURI authority repo
 
-data Role = RoleAdmin deriving (Show, Eq, Enum, Bounded)
+data Role
+    = RoleVisit | RoleReport | RoleTriage | RoleWrite | RoleMaintain | RoleAdmin
+    deriving (Show, Read, Eq, Ord, Enum, Bounded)
 
 instance FromJSON Role where
     parseJSON = withText "Role" parse
         where
-        parse "https://forgefed.org/ns#admin" = pure RoleAdmin
+        parse "visit"    = pure RoleVisit
+        parse "report"   = pure RoleReport
+        parse "triage"   = pure RoleTriage
+        parse "write"    = pure RoleWrite
+        parse "maintain" = pure RoleMaintain
+        parse "admin"    = pure RoleAdmin
         parse t = fail $ "Unknown role: " ++ T.unpack t
 
 instance ToJSON Role where
     toJSON = error "toJSON Role"
     toEncoding r =
         toEncoding $ case r of
-            RoleAdmin -> "https://forgefed.org/ns#admin" :: Text
+            RoleVisit    -> "visit" :: Text
+            RoleReport   -> "report"
+            RoleTriage   -> "triage"
+            RoleWrite    -> "write"
+            RoleMaintain -> "maintain"
+            RoleAdmin    -> "admin"
 
 data Duration = Duration Int
 
@@ -1726,7 +1738,7 @@ encodeFollow (Follow obj mcontext hide)
     <> "hide"    .=  hide
 
 data Grant u = Grant
-    { grantObject   :: Either Role (ObjURI u)
+    { grantObject   :: Role
     , grantContext  :: LocalURI
     , grantTarget   :: ObjURI u
     , grantResult   :: Maybe (LocalURI, Maybe Duration)
@@ -1739,7 +1751,7 @@ data Grant u = Grant
 parseGrant :: UriMode u => Authority u -> Object -> Parser (Grant u)
 parseGrant h o =
     Grant
-        <$> o .:+ "object"
+        <$> o .: "object"
         <*> withAuthorityO h (o .: "context")
         <*> o .: "target"
         <*> (do mres <- o .:+? "result"
@@ -1755,7 +1767,7 @@ parseGrant h o =
 
 encodeGrant :: UriMode u => Authority u -> Grant u -> Series
 encodeGrant h (Grant obj context target mresult mstart mend allows mdelegates)
-    =  "object"  .=+ obj
+    =  "object"  .= obj
     <> "context" .= ObjURI h context
     <> "target"  .= target
     <> (case mresult of
@@ -1772,7 +1784,7 @@ encodeGrant h (Grant obj context target mresult mstart mend allows mdelegates)
     <> "delegates" .=? mdelegates
 
 data Invite u = Invite
-    { inviteInstrument :: Either Role (ObjURI u)
+    { inviteInstrument :: Role
     , inviteObject     :: ObjURI u
     , inviteTarget     :: ObjURI u
     }
@@ -1780,31 +1792,31 @@ data Invite u = Invite
 parseInvite :: UriMode u => Object -> Parser (Invite u)
 parseInvite o =
     Invite
-        <$> o .:+ "instrument"
+        <$> o .: "instrument"
         <*> o .: "object"
         <*> o .: "target"
 
 encodeInvite :: UriMode u => Invite u -> Series
-encodeInvite (Invite obj context target)
+encodeInvite (Invite ins obj target)
-    =  "object"  .=+ obj
+    =  "instrument" .= ins
-    <> "context" .= context
+    <> "object"     .= obj
-    <> "target"  .= target
+    <> "target"     .= target
 
 data Join u = Join
-    { joinInstrument :: Either Role (ObjURI u)
+    { joinInstrument :: Role
     , joinObject     :: ObjURI u
     }
 
 parseJoin :: UriMode u => Object -> Parser (Join u)
 parseJoin o =
     Join
-        <$> o .:+ "instrument"
+        <$> o .: "instrument"
         <*> o .: "object"
 
 encodeJoin :: UriMode u => Join u -> Series
-encodeJoin (Join obj context)
+encodeJoin (Join ins obj)
-    =  "object"  .=+ obj
+    =  "instrument" .= ins
-    <> "context" .= context
+    <> "object"     .= obj
 
 data OfferObject u = OfferTicket (Ticket u) | OfferDep (TicketDependency u)
 

templates/deck/collab/list.hamlet

@@ -21,10 +21,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Collaborator
     <th>Role
     <th>Since
-  $forall (person, ctID, since) <- collabs
+  $forall (person, role, ctID, since) <- collabs
     <tr>
+      <td>#{show role}
       <td>^{personLinkFedW person}
-      <td>Admin
       <td>#{showDate since}
       <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}
 
@@ -36,11 +36,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Invitee
     <th>Role
     <th>Time
-  $forall (inviter, invitee, time) <- invites
+  $forall (inviter, invitee, time, role) <- invites
     <tr>
       <td>^{personLinkFedW inviter}
       <td>^{personLinkFedW invitee}
-      <td>Admin
+      <td>#{show role}
       <td>#{showDate time}
 
 <a href=@{DeckInviteR deckHash}>Invite…
@@ -52,8 +52,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Joiner
     <th>Role
     <th>Time
-  $forall (joiner, time) <- joins
+  $forall (joiner, time, role) <- joins
     <tr>
       <td>^{personLinkFedW joiner}
-      <td>Admin
+      <td>#{show role}
       <td>#{showDate time}

templates/personal-overview.hamlet

@@ -56,23 +56,32 @@ $#       Comment on a ticket or merge request
 <h2>Your repos
 
 <ul>
-  $forall (Entity repoID _, Entity _ actor) <- repos
+  $forall (Entity repoID _, Entity _ actor, Entity _ (Collab role)) <- repos
     <li>
+      [
+      #{show role}
+      ]
       <a href=@{RepoR $ hashRepo repoID}>
         ^#{keyHashidText $ hashRepo repoID} #{actorName actor}
 
 <h2>Your ticket trackers
 
 <ul>
-  $forall (Entity deckID _, Entity _ actor) <- decks
+  $forall (Entity deckID _, Entity _ actor, Entity _ (Collab role)) <- decks
     <li>
+      [
+      #{show role}
+      ]
       <a href=@{DeckR $ hashDeck deckID}>
         =#{keyHashidText $ hashDeck deckID} #{actorName actor}
 
 <h2>Your patch trackers
 
 <ul>
-  $forall (Entity loomID _, Entity _ actor) <- looms
+  $forall (Entity loomID _, Entity _ actor, Entity _ (Collab role)) <- looms
     <li>
+      [
+      #{show role}
+      ]
       <a href=@{LoomR $ hashLoom loomID}>
         +#{keyHashidText $ hashLoom loomID} #{actorName actor}

th/models

@@ -280,24 +280,6 @@ GroupMember
 
     UniqueGroupMember person group
 
--- I'm removing the 'sharer' field, so all roles are now public for everyone to
--- use! This is temporary, until I figure out a sane plan for federated roles
-Role
-    ident  RlIdent
-    desc   Text
-
-RoleInherit
-    parent RoleId
-    child  RoleId
-
-    UniqueRoleInherit parent child
-
-RoleAccess
-    role RoleId
-    op   ProjectOperation
-
-    UniqueRoleAccess role op
-
 -------------------------------------------------------------------------------
 -- Projects
 -------------------------------------------------------------------------------
@@ -307,8 +289,6 @@ Deck
     workflow   WorkflowId
     nextTicket Int
     wiki       RepoId        Maybe
-    collabUser RoleId        Maybe
-    collabAnon RoleId        Maybe
     create     OutboxItemId
 
     UniqueDeckActor  actor
@@ -328,8 +308,6 @@ Repo
     vcs        VersionControlSystem
     project    DeckId               Maybe
     mainBranch Text
-    collabUser RoleId               Maybe
-    collabAnon RoleId               Maybe
     actor      ActorId
     create     OutboxItemId
     loom       LoomId               Maybe
@@ -592,6 +570,7 @@ RemoteMessage
 ------------------------------------------------------------------------------
 
 Collab
+    role Role
 
 -------------------------------- Collab reason -------------------------------
 
@@ -723,24 +702,3 @@ CollabRecipRemoteAccept
     UniqueCollabRecipRemoteAcceptCollab collab
     UniqueCollabRecipRemoteAcceptInvite invite
     UniqueCollabRecipRemoteAcceptAccept accept
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
---RepoRemoteCollab
---    repo   RepoId
---    collab RemoteActorId
---    role   RoleId        Maybe
---    cap    Text
---
---    UniqueRepoRemoteCollab    repo collab
---    UniqueRepoRemoteCollabCap cap
---
---ProjectRemoteCollab
---    project DeckId
---    collab  RemoteActorId
---    role    RoleId        Maybe
---    cap     Text
---
---    UniqueProjectRemoteCollab    project person
---    UniqueProjectRemoteCollabCap cap

vervis.cabal

@@ -237,13 +237,11 @@ library
                        Vervis.Persist.Follow
                        Vervis.Persist.Ticket
 
-                       Vervis.Query
                        Vervis.Readme
                        Vervis.Recipient
                        Vervis.RemoteActorStore
                        Vervis.RemoteActorStore.Types
                        --Vervis.Repo
-                       --Vervis.Role
                        Vervis.Secure
                        Vervis.Settings
                        Vervis.Settings.StaticFiles