S2S: Project: Revoke: Handle child revoking one of the Grants they sent me

src/Vervis/Actor/Project.hs

@@ -1207,6 +1207,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                 deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs]
                 deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs]
                 deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafId <-. leafIDs]
                 case child of
                     Left (localID, _) -> do
                         acceptID <- getKeyByJust $ UniqueSourceThemAcceptLocal localID
@@ -4890,14 +4891,14 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus
         maybeMode <-
             ExceptT $ fmap adapt $ runMaybeT $
                 runExceptT (Left <$> tryParent revokedFirstDB) <|>
-                runExceptT (Right <$> lift mzero)
+                runExceptT (Right <$> tryChild revokedFirstDB)
         fromMaybeE
             maybeMode
             "Revoked activity isn't a relevant Grant I'm aware of"
 
     case mode of
         Left p -> revokeParent revokedRest p
-        Right () -> error "revokeChild c"
+        Right c -> revokeChild revokedRest c
 
     where
 
@@ -4932,11 +4933,39 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus
             lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorRemoteGrant remoteActivityID
         tryParent' usAcceptID (Right sendID) --(Right remoteID)
 
+    verifySourceHolder :: SourceId -> ActDBE ()
+    verifySourceHolder sourceID = do
+        mh <- lift $ getValBy $ UniqueSourceHolderProject sourceID
+        case mh of
+            Just (SourceHolderProject _ j) | j == projectID -> pure ()
+            _ -> throwE "Revoked object is a Grant for some other project/team"
+
+    tryChild' sourceID child = do
+        ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID
+        sendID <- lift $ MaybeT $ getKeyBy $ UniqueSourceUsSendDelegator sourceID
+        return (sendID, child)
+
+    tryChild (Left (_actorByKey, _actorEntity, itemID)) = do
+        Entity delegID (SourceThemDelegateLocal themAcceptID _) <-
+            lift $ MaybeT $ getBy $ UniqueSourceThemDelegateLocal itemID
+        SourceThemAcceptLocal topicID _ <- lift $ lift $ getJust themAcceptID
+        SourceTopicLocal sourceID <- lift $ lift $ getJust topicID
+        SourceTopicProject _ _ j <- do
+            mj <- lift $ lift $ getValBy $ UniqueSourceTopicProjectTopic topicID
+            fromMaybeE mj "The parent to whom this revoked Grant was sent isn't a Project"
+        tryChild' sourceID $ Left (topicID, j, delegID, themAcceptID)
+    tryChild (Right remoteActivityID) = do
+        Entity delegID (SourceThemDelegateRemote themAcceptID _) <-
+            lift $ MaybeT $ getBy $ UniqueSourceThemDelegateRemote remoteActivityID
+        SourceThemAcceptRemote topicID _ <- lift $ lift $ getJust themAcceptID
+        SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID
+        tryChild' sourceID $ Right (topicID, actorID, delegID, themAcceptID)
+
     revokeParent revokedRest (destID, usAcceptID, parent, send) = do
 
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
         unless (author == bimap (LocalActorProject . snd) snd parent) $
-            throwE "Sender isn't the parent Project he revoked Grant came from"
+            throwE "Sender isn't the parent Project the revoked Grant came from"
 
         unless (null revokedRest) $
             throwE "Parent revoking the delegator-Grant and something more"
@@ -5060,6 +5089,143 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    revokeChild revokedRest (sendID, child) = do
+
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (LocalActorProject . view _2) (view _2) child) $
+            throwE "Sender isn't the child Project the revoked Grant came from"
+
+        unless (null revokedRest) $
+            throwE "Child revoking the start/extension-Grant and something more"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRevokeDB $ \ _revokeDB -> do
+
+                -- Collect the extensions I'll need to revoke
+                gatherIDs <-
+                    case child of
+                        Left (_, _, delegID, _) ->
+                            map (sourceUsGatherFromLocalGather . entityVal) <$>
+                                selectList [SourceUsGatherFromLocalFrom ==. delegID] []
+                        Right (_, _, delegID, _) ->
+                            map (sourceUsGatherFromRemoteGather . entityVal) <$>
+                                selectList [SourceUsGatherFromRemoteFrom ==. delegID] []
+                gathers <- selectList [SourceUsGatherId <-. gatherIDs] []
+                leafIDs <-
+                    case child of
+                        Left (_, _, delegID, _) ->
+                            map (sourceUsLeafFromLocalLeaf . entityVal) <$>
+                                selectList [SourceUsLeafFromLocalFrom ==. delegID] []
+                        Right (_, _, delegID, _) ->
+                            map (sourceUsLeafFromRemoteLeaf . entityVal) <$>
+                                selectList [SourceUsLeafFromRemoteFrom ==. delegID] []
+                leafs <- selectList [SourceUsLeafId <-. leafIDs] []
+
+                -- Delete the records of these extensions
+                deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherId <-. gatherIDs]
+                deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafId <-. leafIDs]
+                case child of
+                    Left (_, _, delegID, _) -> delete delegID
+                    Right (_, _, delegID, _) -> delete delegID
+
+                -- Prepare and insert Revokes on all the extension-Grants
+                revokesG <- for gathers $ \ (Entity _ (SourceUsGather _ acceptID grantID)) -> do
+                    DestUsAccept destID _ <- getJust acceptID
+                    parent <- do
+                        p <- getDestTopic destID
+                        bitraverse
+                            (\case
+                                Left j -> pure $ LocalActorProject j
+                                Right _ -> error "I'm a project but I have a parent who is a Group"
+                            )
+                            pure
+                            (bimap snd snd p)
+                    return (parent, grantID)
+                revokesL <- for leafs $ \ (Entity _ (SourceUsLeaf _ enableID grantID)) -> do
+                    CollabEnable collabID _ <- getJust enableID
+                    recip <- getCollabRecip collabID
+                    return
+                        ( bimap
+                            (LocalActorPerson . collabRecipLocalPerson . entityVal)
+                            (collabRecipRemoteActor . entityVal)
+                            recip
+                        , grantID
+                        )
+                revokes <- for (revokesG ++ revokesL) $ \ (actor, grantID) -> do
+                    ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID
+                    let recipByKey = LocalActorProject projectID
+                    extID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                return (projectActor project, revokes)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, revokes) -> do
+                let topicByID = LocalActorProject projectID
+                lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                    sendActivity
+                        topicByID topicActorID localRecipsExt
+                        remoteRecipsExt fwdHostsExt extID actionExt
+                done "Deleted the SourceThemDelegate* record, sent Revokes"
+
+        where
+
+        prepareExtRevoke recipient grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+            let topicByHash = LocalActorProject projectHash
+
+            audRecip <-
+                case recipient of
+                    Left a -> do
+                        h <- hashLocalActor a
+                        return $ AudLocal [h] [localActorFollowers h]
+                    Right actorID -> do
+                        actor <- getJust actorID
+                        ObjURI h lu <- getRemoteActorURI actor
+                        return $
+                            AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audRecip]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+
+            uRevoke <- lift $ getActivityURI authorIdMsig
+            luGrant <- do
+                grantHash <- encodeKeyHashid grantID
+                return $ encodeRouteLocal $ activityRoute topicByHash grantHash
+            let action = AP.Action
+                    { AP.actionCapability = Nothing
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uRevoke]
+                    , AP.actionSpecific   = AP.RevokeActivity AP.Revoke
+                        { AP.revokeObject = luGrant :| []
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: An actor is undoing some previous action
 -- Behavior:
 --      * If they're undoing their Following of me:

src/Vervis/Migration.hs

@@ -3214,6 +3214,14 @@ changes hLocal ctx =
     , addEntities model_577_component_gather
       -- 578
     , addEntities model_578_source_remove
+      -- 579
+    , removeUnique' "SourceThemDelegateLocal" ""
+      -- 580
+    , removeUnique' "SourceThemDelegateRemote" ""
+      -- 581
+    , addUnique' "SourceThemDelegateLocal" "" ["grant"]
+      -- 582
+    , addUnique' "SourceThemDelegateRemote" "" ["grant"]
     ]
 
 migrateDB

th/models

@@ -1,6 +1,6 @@
 -- This file is part of Vervis.
 --
--- Written in 2016, 2018, 2019, 2020, 2022
+-- Written in 2016, 2018, 2019, 2020, 2022, 2024
 -- by fr33domlover <fr33domlover@riseup.net>.
 --
 -- ♡ Copying is an act of love. Please copy, reuse and share.
@@ -1438,13 +1438,13 @@ SourceThemDelegateLocal
     source SourceThemAcceptLocalId
     grant  OutboxItemId
 
-    UniqueSourceThemDelegateLocal source grant
+    UniqueSourceThemDelegateLocal grant
 
 SourceThemDelegateRemote
     source SourceThemAcceptRemoteId
     grant  RemoteActivityId
 
-    UniqueSourceThemDelegateRemote source grant
+    UniqueSourceThemDelegateRemote grant
 
 -- Witnesses that, seeing the delegation from them, I've sent an
 -- extension-Grant to a Dest of mine