From 5d88036fc39cb4bf582116deca2e03f0d0add1ab Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 20 Jun 2024 21:48:48 +0300 Subject: [PATCH] S2S: Group: Revoke: Implement resource mode --- src/Vervis/Actor/Group.hs | 172 +++++++++++++++++++++++++++++++++++++- 1 file changed, 170 insertions(+), 2 deletions(-) diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 80817aa..5b70928 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -5286,6 +5286,10 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do -- * Delete that extension from my Source record -- * For each further extension I did on that Grant (to a -- child/collab), send a Revoke +-- * If it's a resource revoking a Grant it had extended to me: +-- * Delete that extension from my Effort record +-- * For each further extension I did on that Grant (to a +-- child/collab), send a Revoke groupRevoke :: UTCTime -> GroupId @@ -5317,14 +5321,16 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest maybeMode <- ExceptT $ fmap adapt $ runMaybeT $ runExceptT (Left <$> tryChild revokedFirstDB) <|> - runExceptT (Right <$> tryParent revokedFirstDB) + runExceptT (Right . Left <$> tryParent revokedFirstDB) <|> + runExceptT (Right . Right <$> tryResource revokedFirstDB) fromMaybeE maybeMode "Revoked activity isn't a relevant Grant I'm aware of" case mode of Left p -> revokeChild revokedRest p - Right c -> revokeParent revokedRest c + Right (Left c) -> revokeParent revokedRest c + Right (Right r) -> revokeResource revokedRest r where @@ -5383,6 +5389,29 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID tryParent' sourceID $ Right (topicID, actorID, delegID, themAcceptID) + verifyEffortHolder :: EffortId -> MaybeT ActDB () + verifyEffortHolder effortID = do + Effort _ g <- lift $ getJust effortID + guard $ g == groupID + + tryResource' effortID resource = do + lift $ verifyEffortHolder effortID + sendID <- lift $ MaybeT $ getKeyBy $ UniqueEffortUsSendDelegator effortID + return (sendID, resource) + + tryResource (Left (_actorByKey, _actorEntity, itemID)) = do + Entity delegID (EffortThemDelegateLocal themAcceptID _) <- + lift $ MaybeT $ getBy $ UniqueEffortThemDelegateLocal itemID + EffortThemAcceptLocal topicID _ <- lift $ lift $ getJust themAcceptID + EffortTopicLocal effortID r <- lift $ lift $ getJust topicID + tryResource' effortID $ Left (topicID, r, delegID, themAcceptID) + tryResource (Right remoteActivityID) = do + Entity delegID (EffortThemDelegateRemote themAcceptID _) <- + lift $ MaybeT $ getBy $ UniqueEffortThemDelegateRemote remoteActivityID + EffortThemAcceptRemote topicID _ <- lift $ lift $ getJust themAcceptID + EffortTopicRemote effortID actorID <- lift $ lift $ getJust topicID + tryResource' effortID $ Right (topicID, actorID, delegID, themAcceptID) + revokeChild revokedRest (destID, usAcceptID, child, send) = do let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig @@ -5635,6 +5664,145 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest return (action, recipientSet, remoteActors, fwdHosts) + revokeResource revokedRest (sendID, resource) = do + + resource' <- + lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) resource + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (resourceToActor . view _2) (view _2) resource') $ + throwE "Sender isn't the resource the revoked Grant came from" + + unless (null revokedRest) $ + throwE "Resource revoking the start/extension-Grant and something more" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do + + -- Collect the extensions I'll need to revoke + distributeIDs <- + case resource of + Left (_, _, delegID, _) -> + map (effortUsDistributeFromLocalDistribute . entityVal) <$> + selectList [EffortUsDistributeFromLocalFrom ==. delegID] [] + Right (_, _, delegID, _) -> + map (effortUsDistributeFromRemoteDistribute . entityVal) <$> + selectList [EffortUsDistributeFromRemoteFrom ==. delegID] [] + distributes <- selectList [EffortUsDistributeId <-. distributeIDs] [] + leafIDs <- + case resource of + Left (_, _, delegID, _) -> + map (effortUsLeafFromLocalLeaf . entityVal) <$> + selectList [EffortUsLeafFromLocalFrom ==. delegID] [] + Right (_, _, delegID, _) -> + map (effortUsLeafFromRemoteLeaf . entityVal) <$> + selectList [EffortUsLeafFromRemoteFrom ==. delegID] [] + leafs <- selectList [EffortUsLeafId <-. leafIDs] [] + + -- Delete the records of these extensions + deleteWhere [EffortUsDistributeFromLocalDistribute <-. distributeIDs] + deleteWhere [EffortUsDistributeFromRemoteDistribute <-. distributeIDs] + deleteWhere [EffortUsDistributeId <-. distributeIDs] + deleteWhere [EffortUsLeafFromLocalLeaf <-. leafIDs] + deleteWhere [EffortUsLeafFromRemoteLeaf <-. leafIDs] + deleteWhere [EffortUsLeafToLocalLeaf <-. leafIDs] + deleteWhere [EffortUsLeafToRemoteLeaf <-. leafIDs] + deleteWhere [EffortUsLeafId <-. leafIDs] + case resource of + Left (_, _, delegID, _) -> delete delegID + Right (_, _, delegID, _) -> delete delegID + + -- 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, revokes, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, revokes, inboxItemID) -> do + let topicByID = LocalActorGroup groupID + lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + topicByID topicActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "Deleted the EffortThemDelegate* record, sent Revokes" + + where + + 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 + + uRevoke <- 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 = [uRevoke] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + -- Meaning: An actor is undoing some previous action -- Behavior: -- * If they're undoing their Following of me: