S2S: Person: Grant: Record role and resource in Permit record

migrations/592_2024-04-18_permit_extend.model

@@ -0,0 +1,2 @@
+PermitTopicExtend
+    permit PermitPersonSendDelegatorId

migrations/593_2024-04-18_permit_extend.model

@@ -0,0 +1,48 @@
+Person
+PermitTopicEnableLocal
+PermitTopicEnableRemote
+RemoteActivity
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+Permit
+    person PersonId
+    role   Role
+
+PermitPersonGesture
+    permit   PermitId
+    activity OutboxItemId
+
+    UniquePermitPersonGesture         permit
+    UniquePermitPersonGestureActivity activity
+
+PermitPersonSendDelegator
+    permit PermitPersonGestureId
+    grant  OutboxItemId
+
+    UniquePermitPersonSendDelegator      permit
+    UniquePermitPersonSendDelegatorGrant grant
+
+PermitTopicExtend
+    permit PermitPersonSendDelegatorId
+
+PermitTopicExtendLocal
+    permit PermitPersonSendDelegatorId
+    permitNew PermitTopicExtendId
+    topic  PermitTopicEnableLocalId
+    grant  OutboxItemId
+
+    UniquePermitTopicExtendLocalGrant grant
+
+PermitTopicExtendRemote
+    permit PermitPersonSendDelegatorId
+    permitNew PermitTopicExtendId
+    topic  PermitTopicEnableRemoteId
+    grant  RemoteActivityId
+
+    UniquePermitTopicExtendRemoteGrant grant

migrations/601_2024-04-18_permit_extend_resource.model

@@ -0,0 +1,11 @@
+PermitTopicExtendResourceLocal
+    permit PermitTopicExtendId
+    actor  ActorId
+
+    UniquePermitTopicExtendResourceLocal permit
+
+PermitTopicExtendResourceRemote
+    permit PermitTopicExtendId
+    actor  RemoteActorId
+
+    UniquePermitTopicExtendResourceRemote permit

src/Vervis/Actor/Person.hs

@@ -20,6 +20,7 @@ module Vervis.Actor.Person
 where
 
 import Control.Applicative
+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
@@ -71,11 +72,12 @@ import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
-import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Persist.Follow
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
+import Vervis.RemoteActorStore
 import Vervis.Ticket
 
 -- Meaning: Someone is offering a ticket or dependency to a tracker
@@ -888,7 +890,35 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
                         case cap of
                             Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID
                             _ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine"
-                    return $ Right delegatorID
+                    return $ Right (resource, role, delegatorID)
+
+    -- For extension-Grant, get the resource by DB/HTTP, and check role
+    maybeMine' <-
+        for maybeMine $ traverseOf _Right $ \ (resource, roleExt, delegatorID) -> do
+            role <-
+                case roleExt of
+                    AP.RXRole r -> pure r
+                    AP.RXDelegator -> throwE "I've been delegated a Grant with role being delegate"
+            resourceDB <- bitraverse
+                (\ la ->
+                    withDBExcept $ localActorID <$>
+                        getLocalActorEntityE la "Extension-Grant resource not found in DB"
+                )
+                (\ (ObjURI h lu) -> do
+                    manager <- asksEnv envHttpManager
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Resource @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Resource isn't an actor"
+                        Right (Just actor) -> return $ entityKey actor
+                )
+                resource
+            return (resourceDB, role, delegatorID)
 
     maybeNew <- withDBExcept $ do
 
@@ -898,7 +928,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
             (p,) <$> getJust (personActor p)
 
         maybePermit <-
-            for maybeMine $
+            for maybeMine' $
                 bitraverse
                     (\ (role, fulfills) -> do
 
@@ -940,7 +970,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
 
                         return (gestureID, bimap fst fst topic)
                     )
-                    (\ delegatorID -> do
+                    (\ (resourceDB, role, delegatorID) -> do
                         Entity sendID (PermitPersonSendDelegator gestureID _) <- do
                             mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID
                             fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record"
@@ -953,7 +983,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
                             (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                             _ -> throwE "Grant sender isn't the Permit topic"
 
-                        return (sendID, bimap fst fst topic)
+                        return (resourceDB, role, sendID, bimap fst fst topic)
                     )
 
         mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
@@ -1005,23 +1035,30 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
 
                         return (personActor personRecip, sieve, maybeDeleg)
                     )
-                    (\ (sendID, topic) ->
+                    (\ (resourceDB, role, sendID, topic) -> do
-                        case (topic, grantDB) of
+                        extendID <- case (topic, grantDB) of
                             (Left localID, Left (_, _, extID)) -> lift $ do
                                 enableID <- do
                                     me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID
                                     case me of
                                         Just e -> pure e
                                         Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable"
-                                insert_ $ PermitTopicExtendLocal sendID enableID extID
+                                extendID <- insert $ PermitTopicExtend sendID role
+                                insert_ $ PermitTopicExtendLocal extendID enableID extID
+                                return extendID
                             (Right remoteID, Right (_, _, extID)) -> lift $ do
                                 enableID <- do
                                     me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID
                                     case me of
                                         Just e -> pure e
                                         Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable"
-                                insert_ $ PermitTopicExtendRemote sendID enableID extID
+                                extendID <- insert $ PermitTopicExtend sendID role
+                                insert_ $ PermitTopicExtendRemote extendID enableID extID
+                                return extendID
                             _ -> error "personGrant impossible 2"
+                        lift $ case resourceDB of
+                            Left actorID -> insert_ $ PermitTopicExtendResourceLocal extendID actorID
+                            Right actorID -> insert_ $ PermitTopicExtendResourceRemote extendID actorID
                     )
 
     case maybeNew of
@@ -1170,10 +1207,11 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
                 (\ extend -> do
 
                     -- Verify the Permit is mine
-                    sendID <-
+                    extendID <-
                         lift . lift $ case extend of
                             Left k -> permitTopicExtendLocalPermit <$> getJust k
                             Right k -> permitTopicExtendRemotePermit <$> getJust k
+                    PermitTopicExtend sendID _ <- lift . lift $ getJust extendID
                     PermitPersonSendDelegator gestureID _ <- lift . lift $ getJust sendID
                     PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
                     Permit p _ <- lift . lift $ getJust permitID
@@ -1188,7 +1226,7 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
                             _ -> throwE "Revoke sender isn't the Permit topic"
 
                     -- Return data for PermitTopicExtend* deletion
-                    return extend
+                    return (extendID, extend)
                 )
                 found
 
@@ -1199,10 +1237,18 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
                 bitraverse_
                     (\ (permitID, gestureID, topicAndEnable) -> do
                         case topicAndEnable of
-                            Left (_, enableID) ->
+                            Left (_, enableID) -> do
-                                deleteWhere [PermitTopicExtendLocalTopic ==. enableID]
+                                extends <- selectList [PermitTopicExtendLocalTopic ==. enableID] []
-                            Right (_, enableID) ->
+                                let extendIDs = map (permitTopicExtendLocalPermit . entityVal) extends
-                                deleteWhere [PermitTopicExtendRemoteTopic ==. enableID]
+                                    extendLocalIDs = map entityKey extends
+                                deleteWhere [PermitTopicExtendLocalId <-. extendLocalIDs]
+                                deleteWhere [PermitTopicExtendId <-. extendIDs]
+                            Right (_, enableID) -> do
+                                extends <- selectList [PermitTopicExtendRemoteTopic ==. enableID] []
+                                let extendIDs = map (permitTopicExtendRemotePermit . entityVal) extends
+                                    extendRemoteIDs = map entityKey extends
+                                deleteWhere [PermitTopicExtendRemoteId <-. extendRemoteIDs]
+                                deleteWhere [PermitTopicExtendId <-. extendIDs]
                         deleteBy $ UniquePermitPersonSendDelegator gestureID
                         case topicAndEnable of
                             Left (topicID, enableID) -> do
@@ -1230,9 +1276,11 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
                             Right (topicID, _) -> delete topicID
                         delete permitID
                     )
-                    (\case
+                    (\ (extendID, extend) -> do
-                        Left k -> delete k
+                        case extend of
-                        Right k -> delete k
+                            Left k -> delete k
+                            Right k -> delete k
+                        delete extendID
                     )
 
     case maybeNew of

src/Vervis/Handler/Client.hs

@@ -200,9 +200,10 @@ getHomeR = do
                                 Just sendID -> do
                                     topicHash <- VR.hashLocalActor topic
                                     hashItem <- getEncodeKeyHashid
-                                    extIDs <-
+                                    extIDs <- do
+                                        extendIDs <- selectKeysList [PermitTopicExtendPermit ==. sendID] []
                                         map (permitTopicExtendLocalGrant  . entityVal) <$>
-                                            selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId]
+                                            selectList [PermitTopicExtendLocalPermit <-. extendIDs] [Asc PermitTopicExtendLocalId]
                                     for extIDs $ \ extID -> do
                                         info <- getExtInfo $ Left extID
                                         return
@@ -237,7 +238,8 @@ getHomeR = do
                             case delegator of
                                 Nothing -> pure []
                                 Just sendID -> do
-                                    es <- selectList [PermitTopicExtendRemotePermit ==. sendID] [Asc PermitTopicExtendRemoteId]
+                                    extendIDs <- selectKeysList [PermitTopicExtendPermit ==. sendID] []
+                                    es <- selectList [PermitTopicExtendRemotePermit <-. extendIDs] [Asc PermitTopicExtendRemoteId]
                                     for es $ \ (Entity _ (PermitTopicExtendRemote _ _ extID)) -> do
                                         ext <- getJust extID
                                         u <- getRemoteActivityURI ext

src/Vervis/Migration.hs

@@ -3253,6 +3253,94 @@ changes hLocal ctx =
     , removeEntity "ComponentGatherRemote"
       -- 591
     , addEntities model_591_component_gather
+      -- 592
+    , addEntities model_592_permit_extend
+      -- 593
+    , addFieldRefRequired''
+        "PermitTopicExtendLocal"
+        (do permitID <- do
+                personID <- do
+                    mp <- selectFirst [] [Asc Person593Id]
+                    entityKey <$> maybe (error "No people") return mp
+                insert $ Permit593 personID RoleVisit
+            itemID <- do
+                outboxID <- insert Outbox593
+                let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+                insert $ OutboxItem593 outboxID doc defaultTime
+            gestureID <- insert $ PermitPersonGesture593 permitID itemID
+            sendID <- insert $ PermitPersonSendDelegator593 gestureID itemID
+            insertEntity $ PermitTopicExtend593 sendID
+        )
+        (Just $ \ (Entity tempExtendID (PermitTopicExtend593 tempSendID)) -> do
+            l <- selectList [] []
+            for_ l $ \ (Entity k (PermitTopicExtendLocal593 sendID _ _ _)) -> do
+                extendID <- insert $ PermitTopicExtend593 sendID
+                update k [PermitTopicExtendLocal593PermitNew =. extendID]
+
+            PermitPersonSendDelegator593 gestureID itemID <- getJust tempSendID
+            PermitPersonGesture593 permitID _ <- getJust gestureID
+            OutboxItem593 outboxID _ _ <- getJust itemID
+
+            delete tempExtendID
+            delete tempSendID
+            delete gestureID
+            delete itemID
+            delete outboxID
+            delete permitID
+        )
+        "permitNew"
+        "PermitTopicExtend"
+      -- 594
+    , addFieldRefRequired''
+        "PermitTopicExtendRemote"
+        (do let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+            permitID <- do
+                personID <- do
+                    mp <- selectFirst [] [Asc Person593Id]
+                    entityKey <$> maybe (error "No people") return mp
+                insert $ Permit593 personID RoleVisit
+            itemID <- do
+                outboxID <- insert Outbox593
+                insert $ OutboxItem593 outboxID doc defaultTime
+            gestureID <- insert $ PermitPersonGesture593 permitID itemID
+            sendID <- insert $ PermitPersonSendDelegator593 gestureID itemID
+            insertEntity $ PermitTopicExtend593 sendID
+        )
+        (Just $ \ (Entity tempExtendID (PermitTopicExtend593 tempSendID)) -> do
+            l <- selectList [] []
+            for_ l $ \ (Entity k (PermitTopicExtendRemote593 sendID _ _ _)) -> do
+                extendID <- insert $ PermitTopicExtend593 sendID
+                update k [PermitTopicExtendRemote593PermitNew =. extendID]
+
+            PermitPersonSendDelegator593 gestureID itemID <- getJust tempSendID
+            PermitPersonGesture593 permitID _ <- getJust gestureID
+            OutboxItem593 outboxID _ _ <- getJust itemID
+
+            delete tempExtendID
+            delete tempSendID
+            delete gestureID
+            delete itemID
+            delete outboxID
+            delete permitID
+        )
+        "permitNew"
+        "PermitTopicExtend"
+      -- 595
+    , removeField "PermitTopicExtendLocal" "permit"
+      -- 596
+    , removeField "PermitTopicExtendRemote" "permit"
+      -- 597
+    , renameField "PermitTopicExtendLocal" "permitNew" "permit"
+      -- 598
+    , renameField "PermitTopicExtendRemote" "permitNew" "permit"
+      -- 599
+    , addUnique' "PermitTopicExtendLocal" "" ["permit"]
+      -- 600
+    , addUnique' "PermitTopicExtendRemote" "" ["permit"]
+      -- 601
+    , addEntities model_601_permit_extend_resource
+      -- 602
+    , addFieldPrimRequired "PermitTopicExtend" ("RoleAdmin" :: String) "role"
     ]
 
 migrateDB

src/Vervis/Migration/Entities.hs

@@ -72,6 +72,8 @@ module Vervis.Migration.Entities
     , model_578_source_remove
     , model_583_dest_start
     , model_591_component_gather
+    , model_592_permit_extend
+    , model_601_permit_extend_resource
     )
 where
 
@@ -280,3 +282,10 @@ model_583_dest_start = $(schema "583_2024-04-13_dest_start")
 
 model_591_component_gather :: [Entity SqlBackend]
 model_591_component_gather = $(schema "591_2024-04-14_component_gather")
+
+model_592_permit_extend :: [Entity SqlBackend]
+model_592_permit_extend = $(schema "592_2024-04-18_permit_extend")
+
+model_601_permit_extend_resource :: [Entity SqlBackend]
+model_601_permit_extend_resource =
+    $(schema "601_2024-04-18_permit_extend_resource")

src/Vervis/Migration/Model2024.hs

@@ -57,3 +57,6 @@ import Web.ActivityPub
 
 makeEntitiesMigration "584"
     $(modelFile "migrations/584_2024-04-14_delete_gather.model")
+
+makeEntitiesMigration "593"
+    $(modelFile "migrations/593_2024-04-18_permit_extend.model")

th/models

@@ -915,20 +915,38 @@ PermitPersonSendDelegator
 -- Witnesses extension-Grants that the topic has sent, extending chains from
 -- its components/subprojects or projects/superteams
 
-PermitTopicExtendLocal
+PermitTopicExtend
     permit PermitPersonSendDelegatorId
+    role   Role
+
+PermitTopicExtendLocal
+    permit PermitTopicExtendId
     topic  PermitTopicEnableLocalId
     grant  OutboxItemId
 
+    UniquePermitTopicExtendLocal      permit
     UniquePermitTopicExtendLocalGrant grant
 
 PermitTopicExtendRemote
-    permit PermitPersonSendDelegatorId
+    permit PermitTopicExtendId
     topic  PermitTopicEnableRemoteId
     grant  RemoteActivityId
 
+    UniquePermitTopicExtendRemote      permit
     UniquePermitTopicExtendRemoteGrant grant
 
+PermitTopicExtendResourceLocal
+    permit PermitTopicExtendId
+    actor  ActorId
+
+    UniquePermitTopicExtendResourceLocal permit
+
+PermitTopicExtendResourceRemote
+    permit PermitTopicExtendId
+    actor  RemoteActorId
+
+    UniquePermitTopicExtendResourceRemote permit
+
 ------------------------------------------------------------------------------
 -- Components, from project perspective
 ------------------------------------------------------------------------------