S2S: Group: Revoke: Implement resource mode

src/Vervis/Actor/Group.hs

@@ -5286,6 +5286,10 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do
 --          * Delete that extension from my Source record
 --          * For each further extension I did on that Grant (to a
 --            child/collab), send a Revoke
+--      * If it's a resource revoking a Grant it had extended to me:
+--          * Delete that extension from my Effort record
+--          * For each further extension I did on that Grant (to a
+--            child/collab), send a Revoke
 groupRevoke
     :: UTCTime
     -> GroupId
@@ -5317,14 +5321,16 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest
         maybeMode <-
             ExceptT $ fmap adapt $ runMaybeT $
                 runExceptT (Left <$> tryChild revokedFirstDB) <|>
-                runExceptT (Right <$> tryParent revokedFirstDB)
+                runExceptT (Right . Left <$> tryParent revokedFirstDB) <|>
+                runExceptT (Right . Right <$> tryResource revokedFirstDB)
         fromMaybeE
             maybeMode
             "Revoked activity isn't a relevant Grant I'm aware of"
 
     case mode of
         Left p -> revokeChild revokedRest p
-        Right c -> revokeParent revokedRest c
+        Right (Left c) -> revokeParent revokedRest c
+        Right (Right r) -> revokeResource revokedRest r
 
     where
 
@@ -5383,6 +5389,29 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest
         SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID
         tryParent' sourceID $ Right (topicID, actorID, delegID, themAcceptID)
 
+    verifyEffortHolder :: EffortId -> MaybeT ActDB ()
+    verifyEffortHolder effortID = do
+        Effort _ g <- lift $ getJust effortID
+        guard $ g == groupID
+
+    tryResource' effortID resource = do
+        lift $ verifyEffortHolder effortID
+        sendID <- lift $ MaybeT $ getKeyBy $ UniqueEffortUsSendDelegator effortID
+        return (sendID, resource)
+
+    tryResource (Left (_actorByKey, _actorEntity, itemID)) = do
+        Entity delegID (EffortThemDelegateLocal themAcceptID _) <-
+            lift $ MaybeT $ getBy $ UniqueEffortThemDelegateLocal itemID
+        EffortThemAcceptLocal topicID _ <- lift $ lift $ getJust themAcceptID
+        EffortTopicLocal effortID r <- lift $ lift $ getJust topicID
+        tryResource' effortID $ Left (topicID, r, delegID, themAcceptID)
+    tryResource (Right remoteActivityID) = do
+        Entity delegID (EffortThemDelegateRemote themAcceptID _) <-
+            lift $ MaybeT $ getBy $ UniqueEffortThemDelegateRemote remoteActivityID
+        EffortThemAcceptRemote topicID _ <- lift $ lift $ getJust themAcceptID
+        EffortTopicRemote effortID actorID <- lift $ lift $ getJust topicID
+        tryResource' effortID $ Right (topicID, actorID, delegID, themAcceptID)
+
     revokeChild revokedRest (destID, usAcceptID, child, send) = do
 
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
@@ -5635,6 +5664,145 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    revokeResource revokedRest (sendID, resource) = do
+
+        resource' <-
+            lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) resource
+
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (resourceToActor . view _2) (view _2) resource') $
+            throwE "Sender isn't the resource the revoked Grant came from"
+
+        unless (null revokedRest) $
+            throwE "Resource revoking the start/extension-Grant and something more"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (group, actorRecip) <- lift $ do
+                p <- getJust groupID
+                (p,) <$> getJust (groupActor p)
+
+            maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do
+
+                -- Collect the extensions I'll need to revoke
+                distributeIDs <-
+                    case resource of
+                        Left (_, _, delegID, _) ->
+                            map (effortUsDistributeFromLocalDistribute . entityVal) <$>
+                                selectList [EffortUsDistributeFromLocalFrom ==. delegID] []
+                        Right (_, _, delegID, _) ->
+                            map (effortUsDistributeFromRemoteDistribute . entityVal) <$>
+                                selectList [EffortUsDistributeFromRemoteFrom ==. delegID] []
+                distributes <- selectList [EffortUsDistributeId <-. distributeIDs] []
+                leafIDs <-
+                    case resource of
+                        Left (_, _, delegID, _) ->
+                            map (effortUsLeafFromLocalLeaf . entityVal) <$>
+                                selectList [EffortUsLeafFromLocalFrom ==. delegID] []
+                        Right (_, _, delegID, _) ->
+                            map (effortUsLeafFromRemoteLeaf . entityVal) <$>
+                                selectList [EffortUsLeafFromRemoteFrom ==. delegID] []
+                leafs <- selectList [EffortUsLeafId <-. leafIDs] []
+
+                -- Delete the records of these extensions
+                deleteWhere [EffortUsDistributeFromLocalDistribute <-. distributeIDs]
+                deleteWhere [EffortUsDistributeFromRemoteDistribute <-. distributeIDs]
+                deleteWhere [EffortUsDistributeId <-. distributeIDs]
+                deleteWhere [EffortUsLeafFromLocalLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafFromRemoteLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafToLocalLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafToRemoteLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafId <-. leafIDs]
+                case resource of
+                    Left (_, _, delegID, _) -> delete delegID
+                    Right (_, _, delegID, _) -> delete delegID
+
+                -- Prepare and insert Revokes on all the extension-Grants
+                revokesD <- for distributes $ \ (Entity _ (EffortUsDistribute _ startID grantID)) -> do
+                    DestUsStart acceptID _ <- getJust startID
+                    DestUsAccept destID _ <- getJust acceptID
+                    child <- do
+                        c <- getDestTopic destID
+                        bitraverse
+                            (\case
+                                Right j -> pure $ LocalActorGroup j
+                                Left _ -> error "I'm a group but I have a child who is a Project"
+                            )
+                            pure
+                            (bimap snd snd c)
+                    return (child, grantID)
+                revokesL <- for leafs $ \ (Entity _ (EffortUsLeaf _ enableID grantID)) -> do
+                    CollabEnable collabID _ <- getJust enableID
+                    recip <- getCollabRecip collabID
+                    return
+                        ( bimap
+                            (LocalActorPerson . collabRecipLocalPerson . entityVal)
+                            (collabRecipRemoteActor . entityVal)
+                            recip
+                        , grantID
+                        )
+                revokes <- for (revokesD ++ revokesL) $ \ (actor, grantID) -> do
+                    ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID
+                    let recipByKey = LocalActorGroup groupID
+                    extID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                return (groupActor group, revokes, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, revokes, inboxItemID) -> do
+                let topicByID = LocalActorGroup groupID
+                lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                    sendActivity
+                        topicByID topicActorID localRecipsExt
+                        remoteRecipsExt fwdHostsExt extID actionExt
+                doneDB inboxItemID "Deleted the EffortThemDelegate* record, sent Revokes"
+
+        where
+
+        prepareExtRevoke recipient grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            groupHash <- encodeKeyHashid groupID
+            let topicByHash = LocalActorGroup groupHash
+
+            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: