S2S: Project: Grant: When adding component/child, extend Grant to teams
This commit is contained in:
Pere Lev
parent
3fb5e92f44
commit
14ff1b293f
1 changed files with 239 additions and 7 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue