S2S: Group: Accept: Implement remove-resource mode

src/Vervis/Actor/Group.hs

@@ -979,6 +979,19 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
 --              - Resource's followers
 --              - My followers
 --              - The Accept sender (my collaborator)
+--
+-- * Remove-Resource-Passive mode:
+--      * Verify the Effort is enabled
+--      * Verify the sender is the resource
+--      * Delete the entire Effort record
+--      * Forward the Accept to my followers
+--      * Send a Revoke on the delegator-Grant I had for B:
+--          * To: Actor B
+--          * CC: Actor A, B's followers, my followers
+--      * Send a Revoke on every extention-Grant I extended on every
+--        delegation Grant I got from B
+--          * To: The child/member to whom I'd sent the Grant
+--          * CC: -
 groupAccept
     :: UTCTime
     -> GroupId
@@ -1015,7 +1028,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
                 runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
                 runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
                 runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|>
-                runExceptT (Right . Right <$> tryRemoveParent myInboxID accepteeDB)
+                runExceptT (Right . Right . Left <$> tryRemoveParent myInboxID accepteeDB) <|>
+                runExceptT (Right . Right . Right <$> tryRemoveResource myInboxID accepteeDB)
         fromMaybeE
             maybeCollab
             "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
@@ -1024,7 +1038,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
         Left (Left collab) -> addCollab collab
         Left (Right resource) -> addResource resource
         Right (Left cp) -> addChildParent cp
-        Right (Right parent) -> removeParent parent
+        Right (Right (Left parent)) -> removeParent parent
+        Right (Right (Right resource)) -> removeResource resource
 
     where
 
@@ -1247,6 +1262,23 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
             lift $ MaybeT $ getValBy $ UniqueEffortThemGestureRemoteAdd remoteActivityID
         tryAddResourcePassive' themID
 
+    tryRemoveResource' itemID = do
+        EffortRemove sendID _ <-
+            lift $ MaybeT $ getValBy $ UniqueEffortRemove itemID
+        EffortUsSendDelegator effortID grantID <- lift $ lift $ getJust sendID
+        lift $ verifyEffortHolder effortID
+        topic <- lift . lift $ getEffortTopic effortID
+        return (effortID, sendID, grantID, topic)
+
+    tryRemoveResource inboxID (Left (_actorByKey, _actorEntity, itemID)) = do
+        InboxItemLocal _ _ i <-
+            lift $ MaybeT $ getValBy $ UniqueInboxItemLocal inboxID itemID
+        tryRemoveResource' i
+    tryRemoveResource inboxID (Right remoteActivityID) = do
+        InboxItemRemote _ _ i <-
+            lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
+        tryRemoveResource' i
+
     componentIsAuthor ident =
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
         in  author == bimap (resourceToActor . componentResource . snd) snd ident
@@ -2199,6 +2231,216 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    removeResource (effortID, sendID, grantID, resource) = do
+
+        topic <-
+            lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) resource
+
+        -- Verify the sender is the topic
+        unless (theyIsAuthor' topic) $
+            throwE "The Accept isn't by the to-be-removed resource"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (group, actorRecip) <- lift $ do
+                p <- getJust groupID
+                (p,) <$> getJust (groupActor p)
+
+            maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do
+
+                -- Grab extension-Grants that I'm about to revoke
+                distributes <- selectList [EffortUsDistributeEffort ==. sendID] []
+                leafs <- selectList [EffortUsLeafEffort ==. sendID] []
+
+                -- Delete the whole Effort record
+                deleteWhere [EffortRemoveSend ==. sendID]
+                let distributeIDs = map entityKey distributes
+                deleteWhere [EffortUsDistributeFromLocalDistribute <-. distributeIDs]
+                deleteWhere [EffortUsDistributeFromRemoteDistribute <-. distributeIDs]
+                deleteWhere [EffortUsDistributeId <-. distributeIDs]
+                let leafIDs = map entityKey leafs
+                deleteWhere [EffortUsLeafFromLocalLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafFromRemoteLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafToLocalLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafToRemoteLeaf <-. leafIDs]
+                deleteWhere [EffortUsLeafId <-. leafIDs]
+                case resource of
+                    Left (localID, _) -> do
+                        acceptID <- getKeyByJust $ UniqueEffortThemAcceptLocal localID
+                        deleteWhere [EffortThemDelegateLocalEffort ==. acceptID]
+                        delete acceptID
+                    Right (remoteID, _) -> do
+                        acceptID <- getKeyByJust $ UniqueEffortThemAcceptRemote remoteID
+                        deleteWhere [EffortThemDelegateRemoteEffort ==. acceptID]
+                        delete acceptID
+                delete sendID
+                origin <-
+                    requireEitherAlt
+                        (getKeyBy $ UniqueEffortOriginUs effortID)
+                        (getKeyBy $ UniqueEffortOriginThem effortID)
+                        "Neither us nor them"
+                        "Both us and them"
+                case origin of
+                    Left usID -> do
+                        deleteBy $ UniqueEffortUsAccept usID
+                        deleteBy $ UniqueEffortUsGestureLocal usID
+                        deleteBy $ UniqueEffortUsGestureRemote usID
+                        delete usID
+                    Right themID -> do
+                        deleteBy $ UniqueEffortThemGestureLocal themID
+                        deleteBy $ UniqueEffortThemGestureRemote themID
+                        delete themID
+                case resource of
+                    Left (l, _) -> delete l
+                    Right (r, _) -> delete r
+                delete effortID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid groupID
+                    let topicByHash =
+                            LocalActorGroup topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                -- Prepare main Revoke activity and insert to my outbox
+                revoke@(actionRevoke, _, _, _) <- prepareMainRevoke (bimap snd snd topic) grantID
+                let recipByKey = LocalActorGroup groupID
+                revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
+
+                -- 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
+                    resource <- do
+                        p <- getDestTopic destID
+                        bitraverse
+                            (\case
+                                Right j -> pure $ LocalActorGroup j
+                                Left _ -> error "I'm a group but I have a resource who is a Project"
+                            )
+                            pure
+                            (bimap snd snd p)
+                    return (resource, 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, sieve, revokeID, revoke, revokes, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), revokes, inboxItemID) -> do
+                let topicByID = LocalActorGroup groupID
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                lift $ do
+                    sendActivity
+                        topicByID topicActorID localRecipsRevoke
+                        remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+                    for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                        sendActivity
+                            topicByID topicActorID localRecipsExt
+                            remoteRecipsExt fwdHostsExt extID actionExt
+                doneDB inboxItemID "[Remove-Resource mode] Deleted the Resource/Effort, forwarded Accept, sent Revokes"
+
+        where
+
+        prepareMainRevoke resource grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            recipHash <- encodeKeyHashid groupID
+            let topicByHash = LocalActorGroup recipHash
+
+            resourceHash <- bitraverse hashLocalResource pure resource
+
+            audRemover <- lift $ makeAudSenderOnly authorIdMsig
+            audResource <-
+                case resourceHash of
+                    Left lr ->
+                        let la = resourceToActor lr
+                        in  pure $ AudLocal [la] [localActorFollowers la]
+                    Right actorID -> do
+                        actor <- getJust actorID
+                        ObjURI h lu <- getRemoteActorURI actor
+                        return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
+            let audMe = AudLocal [] [localActorFollowers topicByHash]
+
+                (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audRemover, audResource, audMe]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+
+            let uRemove = AP.acceptObject accept
+            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)
+
+        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
+
+            let uRemove = AP.acceptObject accept
+            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)
+
 -- Meaning: Someone has created a group with my ID URI
 -- Behavior:
 --     * Verify I'm in a just-been-created state