S2S: Project: Remove: Implement child/parent mode

migrations/578_2024-04-03_source_remove.model

@@ -0,0 +1,6 @@
+SourceRemove
+    send     SourceUsSendDelegatorId
+    activity InboxItemId
+
+    UniqueSourceRemove         send
+    UniqueSourceRemoveActivity activity

src/Control/Monad/Trans/Except/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -17,6 +17,7 @@ module Control.Monad.Trans.Except.Local
     ( fromMaybeE
     , verifyNothingE
     , nameExceptT
+    , verifySingleE
     )
 where
 
@@ -33,3 +34,9 @@ verifyNothingE (Just _) e = throwE e
 
 nameExceptT :: Functor m => Text -> ExceptT Text m a -> ExceptT Text m a
 nameExceptT title = withExceptT $ \ e -> title <> ": " <> e
+
+verifySingleE list none several =
+    case list of
+        [] -> throwE none
+        [x] -> pure x
+        _ -> throwE several

src/Vervis/Actor/Project.hs

@@ -1445,7 +1445,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
             uCap
             authorIdMsig
             (LocalActorProject projectID)
-            AP.RoleTriage
+            AP.RoleAdmin
 
         maybeNew <- withDBExcept $ do
 
@@ -3580,9 +3580,9 @@ projectReject
     -> ActE (Text, Act (), Next)
 projectReject = topicReject projectActor LocalActorProject
 
--- Meaning: An actor A is removing actor B from a resource
+-- Meaning: An actor A is removing actor B from collection C
 -- Behavior:
---      * Verify the resource is me
+--      * If C is my collaborators collection:
 --          * Verify A isn't removing themselves
 --          * Verify A is authorized by me to remove actors from me
 --          * Verify B already has a Grant for me
@@ -3591,6 +3591,34 @@ projectReject = topicReject projectActor LocalActorProject
 --          * Send a Revoke:
 --              * To: Actor B
 --              * CC: Actor A, B's followers, my followers
+--      * If C is my children collection:
+--          * Verify A isn't removing themselves
+--          * Verify A is authorized by me to remove actors from me
+--          * Verify B is an active child of mine
+--          * Remove the whole Source record from DB
+--          * Forward the Remove 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: -
+--      * If C is my parents collection:
+--          * Verify A isn't removing themselves
+--          * Verify A is authorized by me to remove actors from me
+--          * Verify B is an active parent of mine
+--          * Remove the whole Dest record from DB
+--          * Forward the Remove to my followers
+--          * Send an Accept on the Remove:
+--              * To: Actor B
+--              * CC: Actor A, B's followers, my followers
+--      * If I'm B, being removed from the parents of a child of mine:
+--          * Record this Remove in the Source record
+--          * Forward to followers
+--      * If I'm B, being removed from the children of a parent of mine:
+--          * Do nothing, just waiting for parent to send a Revoke on the
+--            delegator-Grant
 projectRemove
     :: UTCTime
     -> ProjectId
@@ -3599,19 +3627,50 @@ projectRemove
     -> ActE (Text, Act (), Next)
 projectRemove now projectID (Verse authorIdMsig body) remove = do
 
-    -- Check remove
-    memberByKey <- do
     let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (resource, memberOrComp) <- parseRemove author remove
+    (collection, item) <- parseRemove author remove
-        unless (Left (Left $ LocalActorProject projectID) == resource) $
+    case (collection, item) of
-            throwE "Remove topic isn't my collabs URI"
+        (Left (Left (LocalActorProject j)), _) | j == projectID ->
+            removeCollab item
+        (Left (Right (ATProjectChildren j)), _) | j == projectID ->
+            removeChildActive item
+        (Left (Right (ATProjectParents j)), _) | j == projectID ->
+            removeParentActive item
+        (_, Left (LocalActorProject j)) | j == projectID ->
+            case collection of
+                Left (Right (ATProjectParents j)) | j /= projectID ->
+                    removeChildPassive $ Left j
+                Left (Right (ATProjectChildren j)) | j /= projectID ->
+                    removeParentPassive $ Left j
+                Right (ObjURI h luColl) -> do
+                    -- NOTE this is HTTP GET done synchronously in the activity
+                    -- handler
+                    manager <- asksEnv envHttpManager
+                    c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
+                    lu <- fromMaybeE (AP.collectionContext c) "No context"
+                    j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu
+                    case (luColl == AP.projectChildren j, luColl == AP.projectParents j) of
+                        (True, False) ->
+                            removeParentPassive $ Right $ ObjURI h lu
+                        (False, True) ->
+                            removeChildPassive $ Right $ ObjURI h lu
+                        _ -> throwE "Weird collection situation"
+                _ -> throwE "I'm being removed from somewhere irrelevant"
+        _ -> throwE "This Remove isn't for me"
+
+    where
+
+    removeCollab member = do
+
+        -- Check remove
+        memberByKey <-
             bitraverse
                 (\case
                     LocalActorPerson p -> pure p
                     _ -> throwE "Not accepting non-person actors as collabs"
                 )
                 pure
-            memberOrComp
+                member
 
         -- Verify the specified capability gives relevant access
         uCap <- do
@@ -3803,6 +3862,686 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    removeChildActive child = do
+
+        -- If child is local, find it in our DB
+        -- If child is remote, HTTP GET it, verify it's an actor of Project
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        childDB <-
+            bitraverse
+                (\case
+                    LocalActorProject j -> withDBExcept $ getEntityE j "Child not found in DB"
+                    _ -> throwE "Local proposed child of non-project type"
+                )
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Child @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Child isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeProject -> pure ()
+                                _ -> throwE "Remote child type isn't Project"
+                            return (u, actor)
+                )
+                child
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the sender is authorized by me to remove a child
+        verifyCapability''
+            uCap
+            authorIdMsig
+            (LocalActorProject projectID)
+            AP.RoleAdmin
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            -- Verify it's an active child of mine
+            sources <- lift $ case childDB of
+                Left (Entity j _) ->
+                    fmap (map $ \ (s, h, d, E.Value a, E.Value t, E.Value i) -> (s, h, d, Left (a, t, i))) $
+                    E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
+                        E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
+                        E.on $ topic E.^. SourceTopicProjectTopic E.==. accept E.^. SourceThemAcceptLocalTopic
+                        E.on $ holder E.^. SourceHolderProjectId E.==. topic E.^. SourceTopicProjectHolder
+                        E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+                        E.where_ $
+                            holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. SourceTopicProjectChild E.==. E.val j
+                        return
+                            ( source E.^. SourceId
+                            , holder E.^. SourceHolderProjectId
+                            , send
+                            , accept E.^. SourceThemAcceptLocalId
+                            , topic E.^. SourceTopicProjectTopic
+                            , topic E.^. SourceTopicProjectId
+                            )
+                Right (_, Entity a _) ->
+                    fmap (map $ \ (s, h, d, E.Value a, E.Value t) -> (s, h, d, Right (a, t))) $
+                    E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
+                        E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
+                        E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic
+                        E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
+                        E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+                        E.where_ $
+                            holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. SourceTopicRemoteTopic E.==. E.val a
+                        return
+                            ( source E.^. SourceId
+                            , holder E.^. SourceHolderProjectId
+                            , send
+                            , accept E.^. SourceThemAcceptRemoteId
+                            , topic E.^. SourceTopicRemoteId
+                            )
+            (E.Value sourceID, E.Value holderID, Entity sendID (SourceUsSendDelegator _ grantID), topic) <-
+                verifySingleE sources "No source" "Multiple sources"
+
+            maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRemoveDB $ \ _removeDB -> 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 topic of
+                    Left (localID, _, _) -> do
+                        deleteWhere [SourceThemDelegateLocalSource ==. localID]
+                        delete localID
+                    Right (remoteID, _) -> do
+                        deleteWhere [SourceThemDelegateRemoteSource ==. remoteID]
+                        delete remoteID
+                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 topic of
+                    Left (_, l, j) -> delete j >> delete l
+                    Right (_, r) -> delete r
+                delete holderID
+                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, _, _, _) <-
+                    lift $ prepareMainRevoke childDB 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 "Deleted the Child/Source, forwarded Remove, sent Revokes"
+
+        where
+
+        prepareMainRevoke child grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            recipHash <- encodeKeyHashid projectID
+            let topicByHash = LocalActorProject recipHash
+
+            childHash <- bitraverse (encodeKeyHashid . entityKey) pure child
+
+            audRemover <- makeAudSenderOnly authorIdMsig
+            let audChild =
+                    case childHash of
+                        Left j ->
+                            AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
+                        Right (ObjURI h lu, Entity _ actor) ->
+                            AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
+                audMe = AudLocal [] [localActorFollowers topicByHash]
+
+                (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audRemover, audChild, audMe]
+
+                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)
+
+        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
+
+            uRemove <- 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   = [uRemove]
+                    , AP.actionSpecific   = AP.RevokeActivity AP.Revoke
+                        { AP.revokeObject = luGrant :| []
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+    removeParentActive parent = do
+
+        -- If parent is local, find it in our DB
+        -- If parent is remote, HTTP GET it, verify it's an actor of Project
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        parentDB <-
+            bitraverse
+                (\case
+                    LocalActorProject j -> withDBExcept $ getEntityE j "Parent not found in DB"
+                    _ -> throwE "Local proposed parent of non-project type"
+                )
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Parent @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Parent isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeProject -> pure ()
+                                _ -> throwE "Remote parent type isn't Project"
+                            return (u, actor)
+                )
+                parent
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the sender is authorized by me to remove a parent
+        verifyCapability''
+            uCap
+            authorIdMsig
+            (LocalActorProject projectID)
+            AP.RoleAdmin
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            -- Verify it's an active child of mine
+            dests <- lift $ case parentDB of
+                Left (Entity j _) ->
+                    fmap (map $ \ (d, h, a, E.Value l, E.Value t, E.Value s) -> (d, h, a, Left (l, t, s))) $
+                    E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do
+                        E.on $ topic E.^. DestTopicProjectTopic E.==. send E.^. DestThemSendDelegatorLocalTopic
+                        E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
+                        E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
+                        E.where_ $
+                            holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. DestTopicProjectParent E.==. E.val j
+                        return
+                            ( dest E.^. DestId
+                            , holder E.^. DestHolderProjectId
+                            , send E.^. DestThemSendDelegatorLocalDest
+                            , topic E.^. DestTopicProjectTopic
+                            , topic E.^. DestTopicProjectId
+                            , send E.^. DestThemSendDelegatorLocalId
+                            )
+                Right (_, Entity a _) ->
+                    fmap (map $ \ (d, h, a, E.Value t, E.Value s) -> (d, h, a, Right (t, s))) $
+                    E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do
+                        E.on $ topic E.^. DestTopicRemoteId E.==. send E.^. DestThemSendDelegatorRemoteTopic
+                        E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
+                        E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
+                        E.where_ $
+                            holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. DestTopicRemoteTopic E.==. E.val a
+                        return
+                            ( dest E.^. DestId
+                            , holder E.^. DestHolderProjectId
+                            , send E.^. DestThemSendDelegatorRemoteDest
+                            , topic E.^. DestTopicRemoteId
+                            , send E.^. DestThemSendDelegatorRemoteId
+                            )
+
+            (E.Value destID, E.Value holderID, E.Value usAcceptID, topic) <-
+                verifySingleE dests "No dest" "Multiple dests"
+
+            maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRemoveDB $ \ _removeDB -> do
+
+                -- Delete uses of this Dest from my Component records
+                case topic of
+                    Left (_, _, sendID) ->
+                        deleteWhere [ComponentGatherLocalParent ==. sendID]
+                    Right (_, sendID) ->
+                        deleteWhere [ComponentGatherRemoteParent ==. sendID]
+
+                -- Delete uses of this Dest from my Source records
+                case topic of
+                    Left (_, _, sendID) -> do
+                        gatherIDs <-
+                            map (sourceUsGatherToLocalGather . entityVal) <$>
+                                selectList [SourceUsGatherToLocalTo ==. sendID] []
+                        deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherId <-. gatherIDs]
+                    Right (_, sendID) -> do
+                        gatherIDs <-
+                            map (sourceUsGatherToRemoteGather . entityVal) <$>
+                                selectList [SourceUsGatherToRemoteTo ==. sendID] []
+                        deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherId <-. gatherIDs]
+
+                -- Delete the whole Dest record
+                case topic of
+                    Left (_, _, sendID) -> delete sendID
+                    Right (_, sendID) -> delete sendID
+                origin <-
+                    requireEitherAlt
+                        (getKeyBy $ UniqueDestOriginUs destID)
+                        (getKeyBy $ UniqueDestOriginThem destID)
+                        "Neither us nor them"
+                        "Both us and them"
+                deleteBy $ UniqueDestUsGestureLocal destID
+                deleteBy $ UniqueDestUsGestureRemote destID
+                case origin of
+                    Left usID -> delete usID
+                    Right themID -> do
+                        deleteBy $ UniqueDestThemAcceptLocal themID
+                        deleteBy $ UniqueDestThemAcceptRemote themID
+                        deleteBy $ UniqueDestThemGestureLocal themID
+                        deleteBy $ UniqueDestThemGestureRemote themID
+                        delete themID
+                delete usAcceptID
+                case topic of
+                    Left (l, j, _) -> delete j >> delete l
+                    Right (r, _) -> delete r
+                delete holderID
+                delete destID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid projectID
+                    let topicByHash =
+                            LocalActorProject topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                -- Prepare Accept activity
+                accept@(actionAccept, _, _, _) <- prepareAccept parentDB
+                let recipByKey = LocalActorProject projectID
+                acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
+
+                return (projectActor project, sieve, acceptID, accept)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+                let topicByID = LocalActorProject projectID
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                lift $
+                    sendActivity
+                        topicByID topicActorID localRecipsAccept
+                        remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                done "Deleted the Parent/Dest, forwarded Remove, sent Accept"
+
+        where
+
+        prepareAccept parentDB = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            audRemover <- lift $ makeAudSenderOnly authorIdMsig
+            audParent <-
+                case parentDB of
+                    Left (Entity j _) -> do
+                        h <- encodeKeyHashid j
+                        return $ AudLocal [LocalActorProject h] [LocalStageProjectFollowers h]
+                    Right (ObjURI h lu, Entity _ ra) ->
+                        return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+            audMe <-
+                AudLocal [] . pure . LocalStageProjectFollowers <$>
+                    encodeKeyHashid projectID
+            uRemove <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audRemover, audParent, audMe]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Nothing
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uRemove]
+                    , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                        { AP.acceptObject   = uRemove
+                        , AP.acceptResult   = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+    removeChildPassive child = do
+
+        -- If child is local, find it in our DB
+        -- If child is remote, HTTP GET it, verify it's an actor of Project
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        childDB <-
+            bitraverse
+                (\ j -> withDBExcept $ getEntityE j "Child not found in DB")
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Child @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Child isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeProject -> pure ()
+                                _ -> throwE "Remote child type isn't Project"
+                            return (u, actor)
+                )
+                child
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            -- Verify it's an active child of mine
+            sources <- lift $ case childDB of
+                Left (Entity j _) ->
+                    fmap (map $ \ (s, h, d, E.Value a, E.Value t, E.Value i) -> (s, h, d, Left (a, t, i))) $
+                    E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
+                        E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
+                        E.on $ topic E.^. SourceTopicProjectTopic E.==. accept E.^. SourceThemAcceptLocalTopic
+                        E.on $ holder E.^. SourceHolderProjectId E.==. topic E.^. SourceTopicProjectHolder
+                        E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+                        E.where_ $
+                            holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. SourceTopicProjectChild E.==. E.val j
+                        return
+                            ( source E.^. SourceId
+                            , holder E.^. SourceHolderProjectId
+                            , send
+                            , accept E.^. SourceThemAcceptLocalId
+                            , topic E.^. SourceTopicProjectTopic
+                            , topic E.^. SourceTopicProjectId
+                            )
+                Right (_, Entity a _) ->
+                    fmap (map $ \ (s, h, d, E.Value a, E.Value t) -> (s, h, d, Right (a, t))) $
+                    E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
+                        E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
+                        E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic
+                        E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
+                        E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+                        E.where_ $
+                            holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. SourceTopicRemoteTopic E.==. E.val a
+                        return
+                            ( source E.^. SourceId
+                            , holder E.^. SourceHolderProjectId
+                            , send
+                            , accept E.^. SourceThemAcceptRemoteId
+                            , topic E.^. SourceTopicRemoteId
+                            )
+            (E.Value sourceID, E.Value holderID, Entity sendID (SourceUsSendDelegator _ grantID), topic) <-
+                verifySingleE sources "No source" "Multiple sources"
+
+            maybeRemoveDB <- lift $ insertToInbox' now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRemoveDB $ \ (removeID, _) -> do
+
+                -- Record the removal attempt
+                insert_ $ SourceRemove sendID removeID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid projectID
+                    let topicByHash =
+                            LocalActorProject topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                return (projectActor project, sieve)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve) -> do
+                let topicByID = LocalActorProject projectID
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                done "Recorded removal attempt, forwarded Remove"
+
+    removeParentPassive parent = do
+
+        -- If parent is local, find it in our DB
+        -- If parent is remote, HTTP GET it, verify it's an actor of Project
+        -- type, and store in our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
+        -- But for the PoC level, the current situation will hopefully do.
+        parentDB <-
+            bitraverse
+                (\ j -> withDBExcept $ getEntityE j "Parent not found in DB")
+                (\ u@(ObjURI h lu) -> do
+                    instanceID <-
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    result <-
+                        ExceptT $ first (T.pack . displayException) <$>
+                            fetchRemoteActor' instanceID h lu
+                    case result of
+                        Left Nothing -> throwE "Parent @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Parent isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeProject -> pure ()
+                                _ -> throwE "Remote parent type isn't Project"
+                            return (u, actor)
+                )
+                parent
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            -- Verify it's an active parent of mine
+            dests <- lift $ case parentDB of
+                Left (Entity j _) ->
+                    fmap (map $ \ (d, h, a, E.Value l, E.Value t, E.Value s) -> (d, h, a, Left (l, t, s))) $
+                    E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do
+                        E.on $ topic E.^. DestTopicProjectTopic E.==. send E.^. DestThemSendDelegatorLocalTopic
+                        E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
+                        E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
+                        E.where_ $
+                            holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. DestTopicProjectParent E.==. E.val j
+                        return
+                            ( dest E.^. DestId
+                            , holder E.^. DestHolderProjectId
+                            , send E.^. DestThemSendDelegatorLocalDest
+                            , topic E.^. DestTopicProjectTopic
+                            , topic E.^. DestTopicProjectId
+                            , send E.^. DestThemSendDelegatorLocalId
+                            )
+                Right (_, Entity a _) ->
+                    fmap (map $ \ (d, h, a, E.Value t, E.Value s) -> (d, h, a, Right (t, s))) $
+                    E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do
+                        E.on $ topic E.^. DestTopicRemoteId E.==. send E.^. DestThemSendDelegatorRemoteTopic
+                        E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
+                        E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
+                        E.where_ $
+                            holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&.
+                            topic E.^. DestTopicRemoteTopic E.==. E.val a
+                        return
+                            ( dest E.^. DestId
+                            , holder E.^. DestHolderProjectId
+                            , send E.^. DestThemSendDelegatorRemoteDest
+                            , topic E.^. DestTopicRemoteId
+                            , send E.^. DestThemSendDelegatorRemoteId
+                            )
+
+            (E.Value destID, E.Value holderID, E.Value usAcceptID, topic) <-
+                verifySingleE dests "No dest" "Multiple dests"
+
+            maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRemoveDB $ \ _removeDB -> do
+
+                return ()
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just () ->
+                done "Saw the removal attempt, just waiting for the Revoke"
+
 -- Meaning: An actor is undoing some previous action
 -- Behavior:
 --      * If they're undoing their Following of me:

src/Vervis/Federation/Util.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,6 +15,7 @@
 
 module Vervis.Federation.Util
     ( insertToInbox
+    , insertToInbox'
     )
 where
 
@@ -38,6 +39,47 @@ import Vervis.Model
 
 -- | Insert an activity delivered to us into our inbox. Return its
 -- database ID if the activity wasn't already in our inbox.
+insertToInbox'
+    :: UTCTime
+    -> Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> ActivityBody
+    -> InboxId
+    -> Bool
+    -> ActDB
+        (Maybe
+            ( InboxItemId
+            , Either
+                (LocalActorBy Key, ActorId, OutboxItemId)
+                (RemoteAuthor, LocalURI, RemoteActivityId)
+            )
+        )
+insertToInbox' now (Left a@(_, _, outboxItemID)) _body inboxID unread = do
+    inboxItemID <- insert $ InboxItem unread now
+    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
+    case maybeItem of
+        Nothing -> do
+            delete inboxItemID
+            return Nothing
+        Just _ -> return $ Just (inboxItemID, Left a)
+insertToInbox' now (Right (author, luAct, _)) body inboxID unread = do
+    let iidAuthor = remoteAuthorInstance author
+    roid <-
+        either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
+    ractid <- either entityKey id <$> insertBy' RemoteActivity
+        { remoteActivityIdent    = roid
+        , remoteActivityContent  = persistJSONFromBL $ actbBL body
+        , remoteActivityReceived = now
+        }
+    ibiid <- insert $ InboxItem unread now
+    mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
+    case mibrid of
+        Nothing -> do
+            delete ibiid
+            return Nothing
+        Just _ -> return $ Just (ibiid, Right (author, luAct, ractid))
+
 insertToInbox
     :: UTCTime
     -> Either
@@ -53,27 +95,5 @@ insertToInbox
                 (RemoteAuthor, LocalURI, RemoteActivityId)
             )
         )
-insertToInbox now (Left a@(_, _, outboxItemID)) _body inboxID unread = do
+insertToInbox now act body inbox unread =
-    inboxItemID <- insert $ InboxItem unread now
+    fmap snd <$> insertToInbox' now act body inbox unread
-    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-    case maybeItem of
-        Nothing -> do
-            delete inboxItemID
-            return Nothing
-        Just _ -> return $ Just $ Left a
-insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
-    let iidAuthor = remoteAuthorInstance author
-    roid <-
-        either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
-    ractid <- either entityKey id <$> insertBy' RemoteActivity
-        { remoteActivityIdent    = roid
-        , remoteActivityContent  = persistJSONFromBL $ actbBL body
-        , remoteActivityReceived = now
-        }
-    ibiid <- insert $ InboxItem unread now
-    mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid
-    case mibrid of
-        Nothing -> do
-            delete ibiid
-            return Nothing
-        Just _ -> return $ Just $ Right (author, luAct, ractid)

src/Vervis/Migration.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2021, 2022, 2023
+ - Written in 2016, 2018, 2019, 2020, 2021, 2022, 2023, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -3212,6 +3212,8 @@ changes hLocal ctx =
     , addUnique' "SourceThemDelegateRemote" "" ["source", "grant"]
       -- 577
     , addEntities model_577_component_gather
+      -- 578
+    , addEntities model_578_source_remove
     ]
 
 migrateDB

src/Vervis/Migration/Entities.hs

@@ -69,6 +69,7 @@ module Vervis.Migration.Entities
     , model_564_permit
     , model_570_source_dest
     , model_577_component_gather
+    , model_578_source_remove
     )
 where
 
@@ -268,3 +269,6 @@ model_570_source_dest = $(schema "570_2023-12-09_source_dest")
 
 model_577_component_gather :: [Entity SqlBackend]
 model_577_component_gather = $(schema "577_2024-03-13_component_gather")
+
+model_578_source_remove :: [Entity SqlBackend]
+model_578_source_remove = $(schema "578_2024-04-03_source_remove")

th/models

@@ -1510,6 +1510,18 @@ SourceUsLeafToRemote
 
     UniqueSourceUsLeafToRemote leaf
 
+-------------------------------- Source remove -------------------------------
+
+-- Witnesses there's a removal request from the child's side, and I'm waiting
+-- for the child project/team to Accept, which is when I'll do the removal on
+-- my side
+
+SourceRemove
+    send     SourceUsSendDelegatorId
+    activity InboxItemId
+
+    UniqueSourceRemove activity
+
 ------------------------------------------------------------------------------
 -- Inheritance - Giver tracking her receivers
 -- (Project tracking its parents)