S2S: Project: Revoke: Collab: Delete and send Revokes on extensions

src/Vervis/Actor/Project.hs

@@ -4325,6 +4325,9 @@ projectReject = topicReject projectResource LocalResourceProject
 --          * Send a Revoke:
 --              * To: Actor B
 --              * CC: Actor A, B's followers, my followers
+--          * Send revokes on my extensions from:
+--              * My components
+--              * My children
 --
 --      * If C is my components collection:
 --          * Verify A is authorized by me
@@ -4495,23 +4498,48 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
             Entity enableID (CollabEnable _ grantID) <-
                 fromMaybeE maybeEnabled "Remove object isn't a member of me yet"
 
-            -- Verify that at least 1 more enabled Admin collab for me exists
-            otherCollabIDs <-
-               lift $  E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
-                    E.on $
-                        collab E.^. CollabId E.==.
-                        enable E.^. CollabEnableCollab
-                    E.where_ $
-                        collab E.^. CollabTopic E.==. E.val resourceID E.&&.
-                        collab E.^. CollabId E.!=. E.val collabID E.&&.
-                        collab E.^. CollabRole E.==. E.val AP.RoleAdmin
-                    return $ collab E.^. CollabId
-            when (null otherCollabIDs) $
-                throwE "No other admins exist, can't remove"
-
             maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
             lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
 
+                -- Grab grants that I'm about to revoke
+                maybeDeleg <-
+                    case recipID of
+                        Left (E.Value localID) -> fmap Left <$> getKeyBy (UniqueCollabDelegLocalRecip localID)
+                        Right (E.Value remoteID) -> fmap Right <$> getKeyBy (UniqueCollabDelegRemoteRecip remoteID)
+                grantIDs <-
+                    case maybeDeleg of
+                        Nothing -> pure []
+                        Just deleg -> do
+                            fromComponents <-
+                                case deleg of
+                                    Left localID -> do
+                                        furthersL <- selectList [ComponentFurtherLocalCollab ==. localID] []
+                                        deleteWhere [ComponentFurtherLocalCollab ==. localID]
+                                        return $ map (componentFurtherLocalGrant . entityVal) furthersL
+                                    Right remoteID -> do
+                                        furthersL <- selectList [ComponentFurtherRemoteCollab ==. remoteID] []
+                                        deleteWhere [ComponentFurtherRemoteCollab ==. remoteID]
+                                        return $ map (componentFurtherRemoteGrant . entityVal) furthersL
+                            fromChildren <-
+                                case deleg of
+                                    Left localID -> do
+                                        tos <- selectList [SourceUsLeafToLocalTo ==. localID] []
+                                        leafs <- selectList [SourceUsLeafId <-. map (sourceUsLeafToLocalLeaf . entityVal) tos] []
+                                        deleteWhere [SourceUsLeafFromLocalLeaf <-. map entityKey leafs]
+                                        deleteWhere [SourceUsLeafFromRemoteLeaf <-. map entityKey leafs]
+                                        deleteWhere [SourceUsLeafToLocalId <-. map entityKey tos]
+                                        deleteWhere [SourceUsLeafId <-. map entityKey leafs]
+                                        return $ map (sourceUsLeafGrant . entityVal) leafs
+                                    Right remoteID -> do
+                                        tos <- selectList [SourceUsLeafToRemoteTo ==. remoteID] []
+                                        leafs <- selectList [SourceUsLeafId <-. map (sourceUsLeafToRemoteLeaf . entityVal) tos] []
+                                        deleteWhere [SourceUsLeafFromLocalLeaf <-. map entityKey leafs]
+                                        deleteWhere [SourceUsLeafFromRemoteLeaf <-. map entityKey leafs]
+                                        deleteWhere [SourceUsLeafToRemoteId <-. map entityKey tos]
+                                        deleteWhere [SourceUsLeafId <-. map entityKey leafs]
+                                        return $ map (sourceUsLeafGrant . entityVal) leafs
+                            return $ fromComponents ++ fromChildren
+
                 -- Delete the whole Collab record
                 deleteBy $ UniqueCollabDelegLocal enableID
                 deleteBy $ UniqueCollabDelegRemote enableID
@@ -4551,28 +4579,49 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
                             LocalActorProject topicHash
                     return $ makeRecipientSet [] [localActorFollowers topicByHash]
 
+                -- Prepare Revoke activities on extensions sent from components
+                -- and children
+                audCollab <-
+                    case memberDB of
+                        Left (Entity personID _) -> do
+                            personHash <- encodeKeyHashid personID
+                            return $ AudLocal [LocalActorPerson personHash] []
+                        Right (_, ObjURI h lu) ->
+                            return $ AudRemote h [lu] []
+                extensions <- for grantIDs $ \ grantID -> do
+                    revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+                    revoke@(actionRevoke, _, _, _) <- lift $ prepareExtRevoke audCollab grantID
+                    let recipByKey = LocalActorProject projectID
+                    _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
+                    return (revokeID, revoke)
+
                 -- Prepare a Revoke activity and insert to my outbox
                 revoke@(actionRevoke, _, _, _) <-
-                    lift $ prepareRevoke memberDB grantID
+                    lift $ prepareMainRevoke memberDB grantID
                 let recipByKey = LocalActorProject projectID
                 revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
                 _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
 
-                return (topicActorID, sieve, revokeID, revoke, inboxItemID)
+                return (topicActorID, sieve, revokeID, revoke, extensions, inboxItemID)
 
         case maybeNew of
             Nothing -> done "I already have this activity in my inbox"
-            Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
+            Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), extensions, inboxItemID) -> do
                 let topicByID = LocalActorProject projectID
                 forwardActivity authorIdMsig body topicByID topicActorID sieve
-                lift $ sendActivity
+                lift $ do
-                    topicByID topicActorID localRecipsRevoke
+                    sendActivity
-                    remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+                        topicByID topicActorID localRecipsRevoke
-                doneDB inboxItemID "Deleted the Grant/Collab, forwarded Remove, sent Revoke"
+                        remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+                    for_ extensions $ \ (revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) ->
+                        sendActivity
+                            topicByID topicActorID localRecipsRevoke
+                            remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+                doneDB inboxItemID "[Collab] Deleted the Grant/Collab, forwarded Remove, sent Revokes"
 
         where
 
-        prepareRevoke member grantID = do
+        prepareMainRevoke member grantID = do
             encodeRouteHome <- getEncodeRouteHome
             encodeRouteLocal <- getEncodeRouteLocal
 
@@ -4612,6 +4661,32 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+        prepareExtRevoke audCollab grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+            let topicByHash = LocalActorProject projectHash
+                (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audCollab]
+                recips = map encodeRouteHome audLocal ++ audRemote
+
+            uRemove <- 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   = [uRemove]
+                    , AP.actionSpecific   = AP.RevokeActivity AP.Revoke
+                        { AP.revokeObject = luGrant :| []
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
     removeComponentActive item = do
 
         -- Check remove