From 24aba4d370487b24a2cb89ddd3218e3eae640aa8 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 10 Apr 2024 16:27:29 +0300 Subject: [PATCH] S2S: Project: Revoke: Handle child revoking one of the Grants they sent me --- src/Vervis/Actor/Project.hs | 172 +++++++++++++++++++++++++++++++++++- src/Vervis/Migration.hs | 8 ++ th/models | 6 +- 3 files changed, 180 insertions(+), 6 deletions(-) diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index ed2c5e4..86b631a 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -1207,6 +1207,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs] deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs] deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafId <-. leafIDs] case child of Left (localID, _) -> do acceptID <- getKeyByJust $ UniqueSourceThemAcceptLocal localID @@ -4890,14 +4891,14 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus maybeMode <- ExceptT $ fmap adapt $ runMaybeT $ runExceptT (Left <$> tryParent revokedFirstDB) <|> - runExceptT (Right <$> lift mzero) + runExceptT (Right <$> tryChild revokedFirstDB) fromMaybeE maybeMode "Revoked activity isn't a relevant Grant I'm aware of" case mode of Left p -> revokeParent revokedRest p - Right () -> error "revokeChild c" + Right c -> revokeChild revokedRest c where @@ -4932,11 +4933,39 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorRemoteGrant remoteActivityID tryParent' usAcceptID (Right sendID) --(Right remoteID) + verifySourceHolder :: SourceId -> ActDBE () + verifySourceHolder sourceID = do + mh <- lift $ getValBy $ UniqueSourceHolderProject sourceID + case mh of + Just (SourceHolderProject _ j) | j == projectID -> pure () + _ -> throwE "Revoked object is a Grant for some other project/team" + + tryChild' sourceID child = do + ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID + sendID <- lift $ MaybeT $ getKeyBy $ UniqueSourceUsSendDelegator sourceID + return (sendID, child) + + tryChild (Left (_actorByKey, _actorEntity, itemID)) = do + Entity delegID (SourceThemDelegateLocal themAcceptID _) <- + lift $ MaybeT $ getBy $ UniqueSourceThemDelegateLocal itemID + SourceThemAcceptLocal topicID _ <- lift $ lift $ getJust themAcceptID + SourceTopicLocal sourceID <- lift $ lift $ getJust topicID + SourceTopicProject _ _ j <- do + mj <- lift $ lift $ getValBy $ UniqueSourceTopicProjectTopic topicID + fromMaybeE mj "The parent to whom this revoked Grant was sent isn't a Project" + tryChild' sourceID $ Left (topicID, j, delegID, themAcceptID) + tryChild (Right remoteActivityID) = do + Entity delegID (SourceThemDelegateRemote themAcceptID _) <- + lift $ MaybeT $ getBy $ UniqueSourceThemDelegateRemote remoteActivityID + SourceThemAcceptRemote topicID _ <- lift $ lift $ getJust themAcceptID + SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID + tryChild' sourceID $ Right (topicID, actorID, delegID, themAcceptID) + revokeParent revokedRest (destID, usAcceptID, parent, send) = do let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig unless (author == bimap (LocalActorProject . snd) snd parent) $ - throwE "Sender isn't the parent Project he revoked Grant came from" + throwE "Sender isn't the parent Project the revoked Grant came from" unless (null revokedRest) $ throwE "Parent revoking the delegator-Grant and something more" @@ -5060,6 +5089,143 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus return (action, recipientSet, remoteActors, fwdHosts) + revokeChild revokedRest (sendID, child) = do + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (LocalActorProject . view _2) (view _2) child) $ + throwE "Sender isn't the child Project the revoked Grant came from" + + unless (null revokedRest) $ + throwE "Child revoking the start/extension-Grant and something more" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRevokeDB $ \ _revokeDB -> do + + -- Collect the extensions I'll need to revoke + gatherIDs <- + case child of + Left (_, _, delegID, _) -> + map (sourceUsGatherFromLocalGather . entityVal) <$> + selectList [SourceUsGatherFromLocalFrom ==. delegID] [] + Right (_, _, delegID, _) -> + map (sourceUsGatherFromRemoteGather . entityVal) <$> + selectList [SourceUsGatherFromRemoteFrom ==. delegID] [] + gathers <- selectList [SourceUsGatherId <-. gatherIDs] [] + leafIDs <- + case child of + Left (_, _, delegID, _) -> + map (sourceUsLeafFromLocalLeaf . entityVal) <$> + selectList [SourceUsLeafFromLocalFrom ==. delegID] [] + Right (_, _, delegID, _) -> + map (sourceUsLeafFromRemoteLeaf . entityVal) <$> + selectList [SourceUsLeafFromRemoteFrom ==. delegID] [] + leafs <- selectList [SourceUsLeafId <-. leafIDs] [] + + -- Delete the records of these extensions + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafId <-. leafIDs] + case child of + Left (_, _, delegID, _) -> delete delegID + Right (_, _, delegID, _) -> delete delegID + + -- 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, revokes) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, revokes) -> do + let topicByID = LocalActorProject projectID + lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + topicByID topicActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Deleted the SourceThemDelegate* record, sent Revokes" + + where + + 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 + + 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: diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index ded9455..12d6666 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3214,6 +3214,14 @@ changes hLocal ctx = , addEntities model_577_component_gather -- 578 , addEntities model_578_source_remove + -- 579 + , removeUnique' "SourceThemDelegateLocal" "" + -- 580 + , removeUnique' "SourceThemDelegateRemote" "" + -- 581 + , addUnique' "SourceThemDelegateLocal" "" ["grant"] + -- 582 + , addUnique' "SourceThemDelegateRemote" "" ["grant"] ] migrateDB diff --git a/th/models b/th/models index 1204576..ae10d2f 100644 --- a/th/models +++ b/th/models @@ -1,6 +1,6 @@ -- This file is part of Vervis. -- --- Written in 2016, 2018, 2019, 2020, 2022 +-- Written in 2016, 2018, 2019, 2020, 2022, 2024 -- by fr33domlover . -- -- ♡ Copying is an act of love. Please copy, reuse and share. @@ -1438,13 +1438,13 @@ SourceThemDelegateLocal source SourceThemAcceptLocalId grant OutboxItemId - UniqueSourceThemDelegateLocal source grant + UniqueSourceThemDelegateLocal grant SourceThemDelegateRemote source SourceThemAcceptRemoteId grant RemoteActivityId - UniqueSourceThemDelegateRemote source grant + UniqueSourceThemDelegateRemote grant -- Witnesses that, seeing the delegation from them, I've sent an -- extension-Grant to a Dest of mine