S2S: Project: Accept: Implement remove-child mode

src/Vervis/Actor/Project.hs

@@ -196,6 +196,19 @@ import Vervis.Web.Collab
 --                  - Parent's followers
 --                  - My followers
 --                  - The Accept sender (my collaborator)
+--
+-- * Remove-Child-Passive mode:
+--      * Verify the Source is enabled
+--      * Verify the sender is the child
+--      * Delete the entire Source 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 parent/collaborator/team to whom I'd sent the Grant
+--          * CC: -
 projectAccept
     :: UTCTime
     -> ProjectId
@@ -209,6 +222,11 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
 
     collabOrComp_or_child <- withDBExcept $ do
 
+        myInboxID <- lift $ do
+            project <- getJust projectID
+            actor <- getJust $ projectActor project
+            return $ actorInbox actor
+
         -- Find the accepted activity in our DB
         accepteeDB <- do
             a <- getActivity acceptee
@@ -225,18 +243,20 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                 runExceptT (Left . Left <$> tryJoinCollab accepteeDB) <|>
                 runExceptT (Left . Right <$> tryInviteComp accepteeDB) <|>
                 runExceptT (Left . Right <$> tryAddComp accepteeDB) <|>
-                runExceptT (Right <$> tryAddChildActive accepteeDB) <|>
+                runExceptT (Right . Left <$> tryAddChildActive accepteeDB) <|>
-                runExceptT (Right <$> tryAddChildPassive accepteeDB) <|>
+                runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
-                runExceptT (Right <$> tryAddParentActive accepteeDB) <|>
+                runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
-                runExceptT (Right <$> tryAddParentPassive accepteeDB)
+                runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|>
+                runExceptT (Right . Right <$> tryRemoveChild myInboxID accepteeDB)
         fromMaybeE
             maybeCollab
-            "Accepted activity isn't an Invite/Join/Add I'm aware of"
+            "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
 
     case collabOrComp_or_child of
         Left (Left collab) -> addCollab collab
         Left (Right comp) -> addComp comp
-        Right cp -> addChildParent cp
+        Right (Left cp) -> addChildParent cp
+        Right (Right child) -> removeChild child
 
     where
 
@@ -441,6 +461,32 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
             lift $ MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd remoteActivityID
         tryAddParentPassive' themID
 
+    tryRemoveChild' itemID = do
+        SourceRemove sendID _ <-
+            lift $ MaybeT $ getValBy $ UniqueSourceRemove itemID
+        SourceUsSendDelegator sourceID grantID <- lift $ lift $ getJust sendID
+        ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID
+        topic <- do
+            t <- lift . lift $ getSourceTopic sourceID
+            bitraverse
+                (\ (l, k) ->
+                    case k of
+                        Left j -> pure (l, j)
+                        Right _ -> error "Project Source topic is a Group, impossible"
+                )
+                pure
+                t
+        return (sourceID, sendID, grantID, topic)
+
+    tryRemoveChild inboxID (Left (_actorByKey, _actorEntity, itemID)) = do
+        InboxItemLocal _ _ i <-
+            lift $ MaybeT $ getValBy $ UniqueInboxItemLocal inboxID itemID
+        tryRemoveChild' i
+    tryRemoveChild inboxID (Right remoteActivityID) = do
+        InboxItemRemote _ _ i <-
+            lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
+        tryRemoveChild' i
+
     componentIsAuthor ident =
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
         in  author == bimap (componentActor . snd) snd ident
@@ -1127,6 +1173,218 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
+    removeChild (sourceID, sendID, grantID, child) = do
+
+        -- Verify the sender is the topic
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (LocalActorProject . snd) snd child) $
+            throwE "The Accept isn't by the to-be-removed child project"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeAcceptDB $ \ acceptDB -> do
+
+                -- Grab extension-Grants that I'm about to revoke
+                gathers <- selectList [SourceUsGatherSource ==. sendID] []
+                leafs <- selectList [SourceUsLeafSource ==. sendID] []
+
+                -- Delete the whole Source record
+                deleteWhere [SourceRemoveSend ==. sendID]
+                let gatherIDs = map entityKey gathers
+                deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs]
+                deleteWhere [SourceUsGatherId <-. gatherIDs]
+                let leafIDs = map entityKey leafs
+                deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs]
+                deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs]
+                case child of
+                    Left (localID, _) -> do
+                        acceptID <- getKeyByJust $ UniqueSourceThemAcceptLocal localID
+                        deleteWhere [SourceThemDelegateLocalSource ==. acceptID]
+                        delete acceptID
+                    Right (remoteID, _) -> do
+                        acceptID <- getKeyByJust $ UniqueSourceThemAcceptRemote remoteID
+                        deleteWhere [SourceThemDelegateRemoteSource ==. acceptID]
+                        delete acceptID
+                delete sendID
+                origin <-
+                    requireEitherAlt
+                        (getKeyBy $ UniqueSourceOriginUs sourceID)
+                        (getKeyBy $ UniqueSourceOriginThem sourceID)
+                        "Neither us nor them"
+                        "Both us and them"
+                case origin of
+                    Left usID -> do
+                        deleteBy $ UniqueSourceUsAccept usID
+                        deleteBy $ UniqueSourceUsGestureLocal usID
+                        deleteBy $ UniqueSourceUsGestureRemote usID
+                        delete usID
+                    Right themID -> do
+                        deleteBy $ UniqueSourceThemGestureLocal themID
+                        deleteBy $ UniqueSourceThemGestureRemote themID
+                        delete themID
+                case child of
+                    Left (l, _) -> do
+                        deleteBy $ UniqueSourceTopicProjectTopic l
+                        delete l
+                    Right (r, _) ->
+                        delete r
+                deleteBy $ UniqueSourceHolderProject sourceID
+                delete sourceID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid projectID
+                    let topicByHash =
+                            LocalActorProject topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                -- Prepare main Revoke activity and insert to my outbox
+                revoke@(actionRevoke, _, _, _) <- prepareMainRevoke (bimap snd snd child) grantID
+                let recipByKey = LocalActorProject projectID
+                revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
+
+                -- 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, sieve, revokeID, revoke, revokes)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), revokes) -> do
+                let topicByID = LocalActorProject projectID
+                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
+                done "[Remove-Child mode] Deleted the Child/Source, forwarded Accept, sent Revokes"
+
+        where
+
+        prepareMainRevoke child grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            recipHash <- encodeKeyHashid projectID
+            let topicByHash = LocalActorProject recipHash
+
+            childHash <- bitraverse encodeKeyHashid pure child
+
+            audRemover <- lift $ makeAudSenderOnly authorIdMsig
+            audChild <-
+                    case childHash of
+                        Left j ->
+                            pure $
+                            AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
+                        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, audChild, 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
+
+            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
+
+            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)
+
 checkExistingComponents
     :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
 checkExistingComponents projectID componentDB = do