From 646e17fa5672a101194e7109d425db57e50b42ff Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 18 May 2024 21:56:51 +0300 Subject: [PATCH] S2S: Project: Revoke: Implement component & team modes --- src/Vervis/Actor/Person/Client.hs | 4 +- src/Vervis/Actor/Project.hs | 298 +++++++++++++++++++++++++++++- src/Vervis/Data/Collab.hs | 62 ++++--- 3 files changed, 330 insertions(+), 34 deletions(-) diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 9413c3c..a501423 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -1249,9 +1249,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost manager <- asksEnv envHttpManager coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" - AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu - unless (mluCollabs == Just luColl || mluMembers == Just luColl) $ - throwE "Remove origin isn't a collabs list" + AP.ResourceWithCollections _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu return $ ObjURI h lu ) resource diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 4f932a4..76f4467 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -5018,6 +5018,14 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do -- * Delete that extension from my Source record -- * For each further extension I did on that Grant (to a -- parent/collab/team), send a Revoke +-- * If it's a team revoking a delegator-Grant it gave me: +-- * Delete the whole Squad record +-- * Forward the Revoke to my followers +-- * Send Accept to team+followers & my followers +-- * If it's a component revoking a Grant it had extended to me: +-- * Delete that extension from my Component record +-- * For each further extension I did on that Grant (to a +-- parent/collab/team), send a Revoke projectRevoke :: UTCTime -> ProjectId @@ -5045,18 +5053,24 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus a <- getActivity $ second (ObjURI h) revokedFirst fromMaybeE a "Can't find revoked in DB" + meResourceID <- lift $ projectResource <$> getJust projectID + let adapt = maybe (Right Nothing) (either Left (Right . Just)) maybeMode <- ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (Left <$> tryParent revokedFirstDB) <|> - runExceptT (Right <$> tryChild revokedFirstDB) + runExceptT (Left . Left <$> tryParent revokedFirstDB) <|> + runExceptT (Left . Right <$> tryChild revokedFirstDB) <|> + runExceptT (Right . Left <$> tryTeam meResourceID revokedFirstDB) <|> + runExceptT (Right . Right <$> tryComponent revokedFirstDB) fromMaybeE maybeMode "Revoked activity isn't a relevant Grant I'm aware of" case mode of - Left p -> revokeParent revokedRest p - Right c -> revokeChild revokedRest c + Left (Left p) -> revokeParent revokedRest p + Left (Right c) -> revokeChild revokedRest c + Right (Left t) -> revokeTeam revokedRest t + Right (Right c) -> revokeComponent revokedRest c where @@ -5115,6 +5129,48 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID tryChild' sourceID $ Right (topicID, actorID, delegID, themAcceptID) + verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB () + verifySquadHolder meResourceID squadID = do + Squad _ resourceID <- lift $ getJust squadID + guard $ resourceID == meResourceID + + tryTeam' meResourceID usAcceptID send = do + SquadUsAccept squadID _ <- lift $ lift $ getJust usAcceptID + lift $ verifySquadHolder meResourceID squadID + topic <- lift . lift $ getSquadTeam squadID + return (squadID, usAcceptID, topic, send) + + tryTeam r (Left (_actorByKey, _actorEntity, itemID)) = do + Entity sendID (SquadThemSendDelegatorLocal usAcceptID _localID _) <- + lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorLocalGrant itemID + tryTeam' r usAcceptID (Left sendID) --(Left localID) + tryTeam r (Right remoteActivityID) = do + Entity sendID (SquadThemSendDelegatorRemote usAcceptID _remoteID _) <- + lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorRemoteGrant remoteActivityID + tryTeam' r usAcceptID (Right sendID) --(Right remoteID) + + verifyComponentHolder :: ComponentId -> MaybeT ActDB () + verifyComponentHolder componentID = do + Component j _ <- lift $ getJust componentID + guard $ j == projectID + + tryComponent' componentID component = do + lift $ verifyComponentHolder componentID + enableID <- lift $ MaybeT $ getKeyBy $ UniqueComponentEnable componentID + return (enableID, component) + + tryComponent (Left (_actorByKey, _actorEntity, itemID)) = do + Entity delegID (ComponentDelegateLocal topicID _) <- + lift $ MaybeT $ getBy $ UniqueComponentDelegateLocalGrant itemID + ComponentLocal componentID komponentID <- lift $ lift $ getJust topicID + compByKey <- lift $ lift $ getLocalComponent komponentID + tryComponent' componentID $ Left (topicID, compByKey, komponentID, delegID) + tryComponent (Right remoteActivityID) = do + Entity delegID (ComponentDelegateRemote topicID _) <- + lift $ MaybeT $ getBy $ UniqueComponentDelegateRemoteGrant remoteActivityID + ComponentRemote componentID actorID <- lift $ lift $ getJust topicID + tryComponent' componentID $ Right (topicID, actorID, delegID) + revokeParent revokedRest (destID, usAcceptID, parent, send) = do let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig @@ -5367,6 +5423,240 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus return (action, recipientSet, remoteActors, fwdHosts) + revokeTeam revokedRest (squadID, usAcceptID, team, send) = do + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (LocalActorGroup . snd) snd team) $ + throwE "Sender isn't the Team the revoked Grant came from" + + unless (null revokedRest) $ + throwE "Team revoking the delegator-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 $ \ (inboxItemID, _revokeDB) -> do + + maybeStartID <- getKeyBy $ UniqueSquadUsStart usAcceptID + + -- Delete uses of this Squad from my Component records + for_ maybeStartID $ \ squadStartID -> + deleteWhere [ComponentConveyTeam ==. squadStartID] + + -- Delete uses of this Squad from my Source records + for_ maybeStartID $ \ squadStartID -> do + conveyIDs <- selectKeysList [SourceUsConveyTeam ==. squadStartID] [] + deleteWhere [SourceUsConveyFromLocalConvey <-. conveyIDs] + deleteWhere [SourceUsConveyFromRemoteConvey <-. conveyIDs] + deleteWhere [SourceUsConveyId <-. conveyIDs] + + -- Delete the whole Squad record + for_ maybeStartID delete + case send of + Left sendID -> delete sendID + Right sendID -> delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueSquadOriginUs squadID) + (getKeyBy $ UniqueSquadOriginThem squadID) + "Neither us nor them" + "Both us and them" + deleteBy $ UniqueSquadUsGestureLocal squadID + deleteBy $ UniqueSquadUsGestureRemote squadID + case origin of + Left usID -> delete usID + Right themID -> do + deleteBy $ UniqueSquadThemAcceptLocal themID + deleteBy $ UniqueSquadThemAcceptRemote themID + deleteBy $ UniqueSquadThemGestureLocal themID + deleteBy $ UniqueSquadThemGestureRemote themID + delete themID + delete usAcceptID + case team of + Left (l, _) -> delete l + Right (r, _) -> delete r + delete squadID + + -- 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 + let recipByKey = LocalActorProject projectID + acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + + return (projectActor project, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + let topicByID = LocalActorProject projectID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ + sendActivity + topicByID topicActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "Deleted the Team/Squad, forwarded Revoke, sent Accept" + + where + + prepareAccept = do + encodeRouteHome <- getEncodeRouteHome + + audTeam <- makeAudSenderWithFollowers authorIdMsig + audMe <- + AudLocal [] . pure . LocalStageProjectFollowers <$> + encodeKeyHashid projectID + uRevoke <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTeam, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRevoke] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uRevoke + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + revokeComponent revokedRest (enableID, component) = do + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (resourceToActor . componentResource . view _2) (view _2) component) $ + throwE "Sender isn't the component the revoked Grant came from" + + unless (null revokedRest) $ + throwE "Component revoking the start-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 $ \ (inboxItemID, _revokeDB) -> do + + -- Collect the extensions I'll need to revoke + furthersL <- selectList [ComponentFurtherLocalComponent ==. enableID] [] + furthersR <- selectList [ComponentFurtherRemoteComponent ==. enableID] [] + gathers <- selectList [ComponentGatherComponent ==. enableID] [] + conveys <- selectList [ComponentConveyComponent ==. enableID] [] + + -- Delete the records of these extensions + deleteWhere [ComponentFurtherLocalComponent ==. enableID] + deleteWhere [ComponentFurtherRemoteComponent ==. enableID] + deleteWhere [ComponentGatherComponent ==. enableID] + deleteWhere [ComponentConveyComponent ==. enableID] + case component of + Left (_, _, _, delegID) -> delete delegID + Right (_, _, delegID) -> delete delegID + + -- Prepare and insert Revokes on all the extension-Grants + revokesFL <- for furthersL $ \ (Entity _ (ComponentFurtherLocal _ delegID grantID)) -> do + CollabDelegLocal _ recipID _ <- getJust delegID + CollabRecipLocal _ personID <- getJust recipID + return (Left $ LocalActorPerson personID, grantID) + revokesFR <- for furthersR $ \ (Entity _ (ComponentFurtherRemote _ delegID grantID)) -> do + CollabDelegRemote _ recipID _ <- getJust delegID + CollabRecipRemote _ actorID <- getJust recipID + return (Right actorID, grantID) + revokesG <- for gathers $ \ (Entity _ (ComponentGather _ startID grantID)) -> do + DestUsStart acceptID _ <- getJust startID + DestUsAccept destID _ <- getJust acceptID + parent <- do + p <- bimap snd snd <$> 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 + p + return (parent, grantID) + revokesC <- for conveys $ \ (Entity _ (ComponentConvey _ startID grantID)) -> do + SquadUsStart acceptID _ <- getJust startID + SquadUsAccept squadID _ <- getJust acceptID + team <- bimap snd snd <$> getSquadTeam squadID + return (first LocalActorGroup team, grantID) + revokes <- for (revokesFL ++ revokesFR ++ revokesG ++ revokesC) $ \ (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, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, revokes, inboxItemID) -> do + let topicByID = LocalActorProject projectID + lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + topicByID topicActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "Deleted the ComponentDelegate* 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/Data/Collab.hs b/src/Vervis/Data/Collab.hs index aea108f..4424ff5 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -368,6 +368,30 @@ parseAddTarget = \case GroupChildrenR g -> ATGroupChildren <$> WAP.decodeKeyHashidE g "Inavlid team children hashid" + RepoProjectsR k -> + ATRepoProjects <$> + WAP.decodeKeyHashidE k "Inavlid hashid" + DeckProjectsR k -> + ATDeckProjects <$> + WAP.decodeKeyHashidE k "Inavlid hashid" + LoomProjectsR k -> + ATLoomProjects <$> + WAP.decodeKeyHashidE k "Inavlid hashid" + ProjectTeamsR k -> + ATProjectTeams <$> + WAP.decodeKeyHashidE k "Inavlid hashid" + RepoTeamsR k -> + ATRepoTeams <$> + WAP.decodeKeyHashidE k "Inavlid hashid" + DeckTeamsR k -> + ATDeckTeams <$> + WAP.decodeKeyHashidE k "Inavlid hashid" + LoomTeamsR k -> + ATLoomTeams <$> + WAP.decodeKeyHashidE k "Inavlid hashid" + GroupEffortsR k -> + ATGroupEfforts <$> + WAP.decodeKeyHashidE k "Inavlid hashid" _ -> throwE "Not an Add target collection route" parseCollabs route = do @@ -425,6 +449,11 @@ data AddTarget | ATRepoProjects RepoId | ATDeckProjects DeckId | ATLoomProjects LoomId + | ATProjectTeams ProjectId + | ATRepoTeams RepoId + | ATDeckTeams DeckId + | ATLoomTeams LoomId + | ATGroupEfforts GroupId deriving Eq addTargetResource :: AddTarget -> LocalResourceBy Key @@ -437,6 +466,11 @@ addTargetResource = \case ATRepoProjects r -> LocalResourceRepo r ATDeckProjects d -> LocalResourceDeck d ATLoomProjects l -> LocalResourceLoom l + ATProjectTeams j -> LocalResourceProject j + ATRepoTeams r -> LocalResourceRepo r + ATDeckTeams d -> LocalResourceDeck d + ATLoomTeams l -> LocalResourceLoom l + ATGroupEfforts g -> LocalResourceGroup g addTargetComponentProjects = \case ATRepoProjects r -> Just $ ComponentRepo r @@ -475,33 +509,7 @@ parseAdd sender (AP.Add object target role _context) = do parseCollection u = do routeOrRemote <- parseFedURI u bitraverse - (\case - ProjectComponentsR j -> - ATProjectComponents <$> - WAP.decodeKeyHashidE j "Inavlid project components hashid" - ProjectParentsR j -> - ATProjectParents <$> - WAP.decodeKeyHashidE j "Inavlid project parents hashid" - ProjectChildrenR j -> - ATProjectChildren <$> - WAP.decodeKeyHashidE j "Inavlid project children hashid" - GroupParentsR g -> - ATGroupParents <$> - WAP.decodeKeyHashidE g "Inavlid team parents hashid" - GroupChildrenR g -> - ATGroupChildren <$> - WAP.decodeKeyHashidE g "Inavlid team children hashid" - RepoProjectsR r -> - ATRepoProjects <$> - WAP.decodeKeyHashidE r "Inavlid repo projects hashid" - DeckProjectsR d -> - ATDeckProjects <$> - WAP.decodeKeyHashidE d "Inavlid deck projects hashid" - LoomProjectsR l -> - ATLoomProjects <$> - WAP.decodeKeyHashidE l "Inavlid loom projects hashid" - _ -> throwE "Not an Add target collection route" - ) + parseAddTarget pure routeOrRemote