From 14ff1b293f332384b3324c0a40e8f4f89702cd32 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 21 May 2024 02:47:54 +0300 Subject: [PATCH] S2S: Project: Grant: When adding component/child, extend Grant to teams --- src/Vervis/Actor/Project.hs | 246 +++++++++++++++++++++++++++++++++++- 1 file changed, 239 insertions(+), 7 deletions(-) diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index da9d543..fa18828 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -2380,6 +2380,14 @@ data GrantKind -- * Delegates: The Grant I just got from C -- * Result: ProjectParentLiveR for this parent -- * Usage: gatherAndConvey +-- * For each team collaborator of mine, prepare and send an +-- extension-Grant, and store it in the Component record in DB: +-- * Role: The lower among (1) admin (2) the team's role in me +-- * Resource: C +-- * Target: The team +-- * Delegates: The Grant I just got from C +-- * Result: ProjectTeamLiveR for this team +-- * Usage: distribute -- -- * Option 2 - Collaborator sending me a delegator-Grant - Verify that: -- * The sender is a collaborator of mine, A @@ -2419,6 +2427,7 @@ data GrantKind -- * Send extension-Grants and record them in the DB: -- * To each of my direct collaborators -- * To each of my parents +-- * To each of my teams -- -- * Option 4 - Almost-Parent sending me the delegator-Grant -- * Update the Dest record, enabling the parent @@ -2621,7 +2630,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do ) localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value _delegID, E.Value grantID, E.Value startID) -> do extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - --insert_ $ ComponentFurtherLocal enableID delegID extID + insert_ $ ComponentGather enableID startID extID ext@(actionExt, _, _, _) <- prepareExtensionGrantForParent identForCheck (Left (parentID, grantID)) (min role role') startID let recipByKey = LocalActorProject projectID @@ -2646,18 +2655,67 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do ) remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value _delegID, E.Value grantID, E.Value startID) -> do extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - --insert_ $ ComponentFurtherRemote enableID delegID extID + insert_ $ ComponentGather enableID startID extID ext@(actionExt, _, _, _) <- prepareExtensionGrantForParent identForCheck (Right (parentID, grantID)) (min role role') startID let recipByKey = LocalActorProject projectID _luExt <- updateOutboxItem' recipByKey extID actionExt return (extID, ext) + -- For each team of mine, prepare a delegation-extension Grant + localTeams <- + lift $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicLocalId E.==. deleg E.^. SquadThemSendDelegatorLocalTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad + E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID + return + ( squad E.^. SquadRole + , topic E.^. SquadTopicLocalGroup + , deleg E.^. SquadThemSendDelegatorLocalId + , deleg E.^. SquadThemSendDelegatorLocalGrant + , start E.^. SquadUsStartId + ) + localExtensionsForTeams <- lift $ for localTeams $ \ (E.Value role', E.Value groupID, E.Value _delegID, E.Value grantID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ ComponentConvey enableID startID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForTeam identForCheck (Left (groupID, grantID)) (min role role') startID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteTeams <- + lift $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicRemoteId E.==. deleg E.^. SquadThemSendDelegatorRemoteTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad + E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID + return + ( squad E.^. SquadRole + , topic E.^. SquadTopicRemoteTopic + , deleg E.^. SquadThemSendDelegatorRemoteId + , deleg E.^. SquadThemSendDelegatorRemoteGrant + , start E.^. SquadUsStartId + ) + remoteExtensionsForTeams <- lift $ for remoteTeams $ \ (E.Value role', E.Value teamID, E.Value _delegID, E.Value grantID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ ComponentConvey enableID startID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForTeam identForCheck (Right (teamID, grantID)) (min role role') startID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + return ( recipActorID , sieve - , localExtensions ++ localExtensionsForParents - , remoteExtensions ++ remoteExtensionsForParents + , localExtensions ++ localExtensionsForParents ++ localExtensionsForTeams + , remoteExtensions ++ remoteExtensionsForParents ++ remoteExtensionsForTeams , inboxItemID ) @@ -2803,6 +2861,68 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + prepareExtensionGrantForTeam component parent role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + uStart <- lift $ getActivityURI authorIdMsig + + (uParent, audParent, uDeleg) <- + case parent of + Left (j, itemID) -> do + h <- encodeKeyHashid j + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ GroupR h + , AudLocal [LocalActorGroup h] [] + , encodeRouteHome $ GroupOutboxItemR h itemHash + ) + Right (raID, ractID) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + uAct <- do + ract <- getJust ractID + getRemoteActivityURI ract + return (u, AudRemote h [lu] [], uAct) + + uComponent <- + case component of + Left c -> do + a <- resourceToActor . componentResource <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + resultR <- do + startHash <- encodeKeyHashid startID + return $ ProjectTeamLiveR projectHash startHash + + let audience = [audParent] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = uComponent + , AP.grantTarget = uParent + , AP.grantResult = + Just (encodeRouteLocal resultR, Nothing) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + tryCollab (GKDelegationStart _) = lift mzero tryCollab (GKDelegationExtend _ _) = lift mzero tryCollab GKDelegator = do @@ -3275,10 +3395,67 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do _luExt <- updateOutboxItem' recipByKey extID actionExt return (extID, ext) + -- For each team of mine, prepare a delegation-extension Grant + localTeams <- + lift $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicLocalId E.==. deleg E.^. SquadThemSendDelegatorLocalTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad + E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID + return + ( squad E.^. SquadRole + , topic E.^. SquadTopicLocalGroup + , deleg E.^. SquadThemSendDelegatorLocalId + , deleg E.^. SquadThemSendDelegatorLocalGrant + , accept E.^. SquadUsAcceptId + , start E.^. SquadUsStartId + ) + localExtensionsForTeams <- lift $ for localTeams $ \ (E.Value role', E.Value groupID, E.Value _delegID, E.Value grantID, E.Value _acceptID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + conveyID <- insert $ SourceUsConvey sendID startID extID + case from of + Left localID -> insert_ $ SourceUsConveyFromLocal conveyID localID + Right remoteID -> insert_ $ SourceUsConveyFromRemote conveyID remoteID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForTeam (Left (groupID, grantID)) (min role role') startID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteTeams <- + lift $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicRemoteId E.==. deleg E.^. SquadThemSendDelegatorRemoteTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad + E.where_ $ squad E.^. SquadHolder E.==. E.val resourceID + return + ( squad E.^. SquadRole + , topic E.^. SquadTopicRemoteTopic + , deleg E.^. SquadThemSendDelegatorRemoteId + , deleg E.^. SquadThemSendDelegatorRemoteGrant + , accept E.^. SquadUsAcceptId + , start E.^. SquadUsStartId + ) + remoteExtensionsForTeams <- lift $ for remoteTeams $ \ (E.Value role', E.Value teamID, E.Value _delegID, E.Value grantID, E.Value _acceptID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + conveyID <- insert $ SourceUsConvey sendID startID extID + case from of + Left localID -> insert_ $ SourceUsConveyFromLocal conveyID localID + Right remoteID -> insert_ $ SourceUsConveyFromRemote conveyID remoteID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForTeam (Right (teamID, grantID)) (min role role') startID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + return ( recipActorID - , localExtensions ++ localExtensionsForParents - , remoteExtensions ++ remoteExtensionsForParents + , localExtensions ++ localExtensionsForParents ++ localExtensionsForTeams + , remoteExtensions ++ remoteExtensionsForParents ++ remoteExtensionsForTeams , inboxItemID ) @@ -3291,7 +3468,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do sendActivity recipByID recipActorID localRecipsExt remoteRecipsExt fwdHostsExt extID actionExt - doneDB inboxItemID "Sent extensions to collabs & parents" + doneDB inboxItemID "Sent extensions to collabs & parents & teams" where @@ -3410,6 +3587,61 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + prepareExtensionGrantForTeam parent role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + uStart <- lift $ getActivityURI authorIdMsig + + (uParent, audParent, uDeleg) <- + case parent of + Left (j, itemID) -> do + h <- encodeKeyHashid j + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ GroupR h + , AudLocal [LocalActorGroup h] [] + , encodeRouteHome $ GroupOutboxItemR h itemHash + ) + Right (raID, ractID) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + uAct <- do + ract <- getJust ractID + getRemoteActivityURI ract + return (u, AudRemote h [lu] [], uAct) + + resultR <- do + startHash <- encodeKeyHashid startID + return $ ProjectTeamLiveR projectHash startHash + + let audience = [audParent] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = AP.grantContext grant + , AP.grantTarget = uParent + , AP.grantResult = + Just (encodeRouteLocal resultR, Nothing) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + tryParent (GKDelegationStart _) = lift mzero tryParent (GKDelegationExtend _ _) = lift mzero tryParent GKDelegator = do