From 9df437a043f3717f465f099b480500031c435127 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 20 Jun 2024 17:58:26 +0300 Subject: [PATCH] S2S: Group: Remove: Implement resource-active mode --- src/Vervis/Actor/Group.hs | 294 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 294 insertions(+) diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index b73468c..bfb0f12 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -3956,6 +3956,18 @@ groupReject = topicReject groupResource LocalResourceGroup -- * Send an Accept on the Remove: -- * To: Actor B -- * CC: Actor A, B's followers, my followers +-- * If C is my resources collection: +-- * Verify A is authorized by me to remove resources from me +-- * Verify B is an active resource of mine +-- * Remove the whole Effort 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 child/member to whom I'd sent the Grant +-- * CC: - -- * If I'm B, being removed from the children of a parent of mine: -- * Record this Remove in the Source record -- * Forward to followers @@ -3979,6 +3991,8 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do removeChildActive item (Left (Right (ATGroupParents j)), _) | j == groupID -> removeParentActive item + (Left (Right (ATGroupEfforts j)), _) | j == groupID -> + removeResourceActive item (_, Left (LocalActorGroup j)) | j == groupID -> case collection of Left (Right (ATGroupParents j)) | j /= groupID -> @@ -4872,6 +4886,286 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do Just inboxItemID -> doneDB inboxItemID "[Child-passive] Saw the removal attempt, just waiting for the Revoke" + removeResourceActive resource = do + + -- If resource is local, find it in our DB + -- If resource is remote, HTTP GET it, verify it's an actor of Group + -- 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. + resourceDB <- + bitraverse + (\ la -> + case resourceToNG =<< actorToResource la of + Just ng -> withDBExcept $ getLocalResourceEntityE (resourceFromNG ng) "Resource not found in DB" + Nothing -> throwE "Local resource of non-resource 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 "Resource @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Resource isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote resource type isn't Group" + return (u, actor) + ) + resource + + -- 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 resource + verifyCapability'' + uCap + authorIdMsig + (LocalResourceGroup groupID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + -- Verify it's an active resource of mine + efforts <- lift $ case resourceDB of + Left r -> + fmap (map $ \ (s, d, E.Value a, E.Value t) -> (s, d, Left (a, t))) $ + E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do + E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort + E.on $ topic E.^. EffortTopicLocalId E.==. accept E.^. EffortThemAcceptLocalTopic + E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort + E.where_ $ + effort E.^. EffortHolder E.==. E.val groupID E.&&. + topic E.^. EffortTopicLocalTopic E.==. E.val (localResourceID r) + return + ( effort E.^. EffortId + , send + , accept E.^. EffortThemAcceptLocalId + , topic E.^. EffortTopicLocalId + ) + Right (_, Entity a _) -> + fmap (map $ \ (s, d, E.Value a, E.Value t) -> (s, d, Right (a, t))) $ + E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do + E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort + E.on $ topic E.^. EffortTopicRemoteId E.==. accept E.^. EffortThemAcceptRemoteTopic + E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort + E.where_ $ + effort E.^. EffortHolder E.==. E.val groupID E.&&. + topic E.^. EffortTopicRemoteTopic E.==. E.val a + return + ( effort E.^. EffortId + , send + , accept E.^. EffortThemAcceptRemoteId + , topic E.^. EffortTopicRemoteId + ) + (E.Value effortID, Entity sendID (EffortUsSendDelegator _ grantID), topic) <- + verifySingleE efforts "No effort" "Multiple efforts" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> 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 topic of + Left (localID, _) -> do + deleteWhere [EffortThemDelegateLocalEffort ==. localID] + delete localID + Right (remoteID, _) -> do + deleteWhere [EffortThemDelegateRemoteEffort ==. remoteID] + delete remoteID + 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 topic 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, _, _, _) <- + lift $ prepareMainRevoke resourceDB 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 + 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, 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 "[Resource-active] Deleted the Effort, forwarded Remove, sent Revokes" + + where + + prepareMainRevoke resource grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + recipHash <- encodeKeyHashid groupID + let topicByHash = LocalActorGroup recipHash + + resourceHash <- bitraverse (hashLocalResource . bmap entityKey) pure resource + + audRemover <- makeAudSenderOnly authorIdMsig + let audResource = + case resourceHash of + Left lr -> + let la = resourceToActor lr + in AudLocal [la] [localActorFollowers la] + Right (ObjURI h lu, Entity _ actor) -> + AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) + audMe = AudLocal [] [localActorFollowers topicByHash] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRemover, audResource, 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 + + 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 + + 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) + -- Meaning: An actor is revoking Grant activities -- Behavior: -- * For each revoked activity: