diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index fa18828..04ca677 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -4325,6 +4325,20 @@ projectReject = topicReject projectResource LocalResourceProject -- * Send a Revoke: -- * To: Actor B -- * CC: Actor A, B's followers, my followers +-- +-- * If C is my components collection: +-- * Verify A is authorized by me +-- * Verify B is an active component of mine +-- * Remove the whole Component record from DB +-- * Forward the Remove to my followers +-- * Send a Revoke on the delegator-Grant: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- * Send revokes on my extensions of the start-Grant to: +-- * My collaborators +-- * My teams +-- * My parents +-- -- * If C is my children collection: -- * Verify A isn't removing themselves -- * Verify A is authorized by me to remove actors from me @@ -4338,6 +4352,7 @@ projectReject = topicReject projectResource LocalResourceProject -- 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 @@ -4347,9 +4362,11 @@ projectReject = topicReject projectResource LocalResourceProject -- * 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 @@ -4366,6 +4383,8 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do case (collection, item) of (Left (Left (LocalResourceProject j)), _) | j == projectID -> removeCollab item + (Left (Right (ATProjectComponents j)), _) | j == projectID -> + removeComponentActive item (Left (Right (ATProjectChildren j)), _) | j == projectID -> removeChildActive item (Left (Right (ATProjectParents j)), _) | j == projectID -> @@ -4593,6 +4612,280 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do return (action, recipientSet, remoteActors, fwdHosts) + removeComponentActive item = do + + -- Check remove + component <- + bitraverse + (\ la -> + fromMaybeE + (resourceToComponent =<< actorToResource la) + "Local component isn't of a component type" + ) + pure + item + + -- Verify the specified capability gives relevant access + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceProject projectID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Find member in our DB + componentDB <- + bitraverse + (flip getComponentE "Local removee not found in DB") + (\ u@(ObjURI h lu) -> (,u) <$> do + maybeActor <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance h + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu + MaybeT $ getBy $ UniqueRemoteActor roid + fromMaybeE maybeActor "Remote removee not found in DB" + ) + component + + -- Grab me from DB + resourceID <- lift $ projectResource <$> getJust projectID + Resource topicActorID <- lift $ getJust resourceID + topicActor <- lift $ getJust topicActorID + + -- Find the Component record + existingComponentIDs <- + lift $ case first localComponentID componentDB of + Left komponentID -> + fmap (map $ over _1 Left) $ + E.select $ E.from $ \ (comp `E.InnerJoin` local `E.InnerJoin` enable) -> do + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.on $ comp E.^. ComponentId E.==. local E.^. ComponentLocalComponent + E.where_ $ + comp E.^. ComponentProject E.==. E.val projectID E.&&. + local E.^. ComponentLocalActor E.==. E.val komponentID + return + ( local E.^. ComponentLocalId + , comp E.^. ComponentId + , enable + ) + Right (Entity remoteActorID _, _) -> + fmap (map $ over _1 Right) $ + E.select $ E.from $ \ (comp `E.InnerJoin` remote `E.InnerJoin` enable) -> do + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.on $ comp E.^. ComponentId E.==. remote E.^. ComponentRemoteComponent + E.where_ $ + comp E.^. ComponentProject E.==. E.val projectID E.&&. + remote E.^. ComponentRemoteActor E.==. E.val remoteActorID + return + ( remote E.^. ComponentRemoteId + , comp E.^. ComponentId + , enable + ) + (recipID, E.Value componentID, Entity enableID (ComponentEnable _ grantID)) <- + case existingComponentIDs of + [] -> throwE "Remove object isn't a collaborator of me" + [c] -> return c + _ -> error "Multiple enabled Components found for removee" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do + + usOrThem <- + requireEitherAlt + (getKeyBy $ UniqueComponentOriginInvite componentID) + (getKeyBy $ UniqueComponentOriginAdd componentID) + "Neither us nor them" + "Both us and them" + + -- Grab extension-Grants that I'm about to revoke + furthersL <- selectList [ComponentFurtherLocalComponent ==. enableID] [] + furthersR <- selectList [ComponentFurtherRemoteComponent ==. enableID] [] + gathers <- selectList [ComponentGatherComponent ==. enableID] [] + conveys <- selectList [ComponentConveyComponent ==. enableID] [] + + -- Delete the whole Component record + deleteWhere [ComponentFurtherLocalComponent ==. enableID] + deleteWhere [ComponentFurtherRemoteComponent ==. enableID] + deleteWhere [ComponentGatherComponent ==. enableID] + deleteWhere [ComponentConveyComponent ==. enableID] + case recipID of + Left (E.Value localID) -> deleteBy $ UniqueComponentDelegateLocal localID + Right (E.Value remoteID) -> deleteBy $ UniqueComponentDelegateRemote remoteID + delete enableID + case usOrThem of + Left usID -> do + deleteBy $ UniqueComponentProjectAccept usID + delete usID + Right themID -> do + deleteBy $ UniqueComponentGestureLocal themID + deleteBy $ UniqueComponentGestureRemote themID + delete themID + deleteBy $ UniqueComponentProjectGestureLocal componentID + deleteBy $ UniqueComponentProjectGestureRemote componentID + case recipID of + Left (E.Value localID) -> do + deleteBy $ UniqueComponentAcceptLocal localID + delete localID + Right (E.Value remoteID) -> do + deleteBy $ UniqueComponentAcceptRemote remoteID + delete remoteID + delete componentID + + -- 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 componentDB grantID + let recipByKey = LocalActorProject projectID + revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now + _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke + + -- Prepare and insert Revokes on all the extension-Grants + revokesG <- for gathers $ \ (Entity _ (ComponentGather _ startID grantID)) -> do + DestUsStart acceptID _ <- getJust startID + 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) + revokesFL <- for furthersL $ \ (Entity _ (ComponentFurtherLocal _ delegID grantID)) -> do + CollabDelegLocal _ recipLocalID _ <- getJust delegID + CollabRecipLocal _ personID <- getJust recipLocalID + return + ( Left $ LocalActorPerson personID + , grantID + ) + revokesFR <- for furthersR $ \ (Entity _ (ComponentFurtherRemote _ delegID grantID)) -> do + CollabDelegRemote _ recipRemoteID _ <- getJust delegID + CollabRecipRemote _ actorID <- getJust recipRemoteID + return + ( Right actorID + , grantID + ) + revokesC <- for conveys $ \ (Entity _ (ComponentConvey _ startID grantID)) -> do + SquadUsStart acceptID _ <- getJust startID + SquadUsAccept squadID _ <- getJust acceptID + team <- bimap (LocalActorGroup . snd) snd <$> getSquadTeam squadID + return (team, grantID) + revokes <- for (revokesG ++ revokesFL ++ revokesFR ++ revokesC) $ \ (actor, grantID) -> do + ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID + let recipByKey = LocalActorProject projectID + extID <- insertEmptyOutboxItem' (actorOutbox topicActor) now + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return (topicActorID, 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 = 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 + doneDB inboxItemID "[Component-active] Deleted the Component, forwarded Remove, sent Revokes" + + where + + prepareMainRevoke component grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + recipHash <- encodeKeyHashid projectID + let topicByHash = LocalActorProject recipHash + + componentHash <- bitraverse (hashComponent . bmap entityKey) pure component + + audRemover <- makeAudSenderOnly authorIdMsig + let audChild = + case componentHash of + Left c -> + let a = resourceToActor $ componentResource c + in AudLocal [a] [localActorFollowers a] + Right (Entity _ actor, ObjURI h lu) -> + 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) + removeChildActive child = do -- If child is local, find it in our DB diff --git a/th/models b/th/models index cb1163d..a5cb2df 100644 --- a/th/models +++ b/th/models @@ -1026,8 +1026,8 @@ ComponentEnable UniqueComponentEnable component UniqueComponentEnableGrant grant --- Witnesses that the component used the delegator Grant to send an admin --- delegation to the project, to extend the delegation further +-- Witnesses that the component used the delegator Grant to send a start-Grant +-- to the project, to extend further ComponentDelegateLocal component ComponentLocalId @@ -1043,7 +1043,7 @@ ComponentDelegateRemote UniqueComponentDelegateRemote component UniqueComponentDelegateRemoteGrant grant --- Witnesses that the project has extended a given delegation to a given +-- Witnesses that the project has extended the start-Grant to a given -- direct collaborator ComponentFurtherLocal @@ -1062,7 +1062,7 @@ ComponentFurtherRemote UniqueComponentFurtherRemote component collab UniqueComponentFurtherRemoteGrant grant --- Witnesses that the project has extended a given delegation to a given +-- Witnesses that the project has extended the start-Grant to a given -- parent ComponentGather @@ -1073,7 +1073,7 @@ ComponentGather UniqueComponentGather component parent UniqueComponentGatherGrant grant --- Witnesses that the project has extended the delegation to a given team +-- Witnesses that the project has extended the start-Grant to a given team ComponentConvey component ComponentEnableId