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
|
-- * Delegates: The Grant I just got from C
|
||||||
-- * Result: ProjectParentLiveR for this parent
|
-- * Result: ProjectParentLiveR for this parent
|
||||||
-- * Usage: gatherAndConvey
|
-- * 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:
|
-- * Option 2 - Collaborator sending me a delegator-Grant - Verify that:
|
||||||
-- * The sender is a collaborator of mine, A
|
-- * The sender is a collaborator of mine, A
|
||||||
|
|
@ -2419,6 +2427,7 @@ data GrantKind
|
||||||
-- * Send extension-Grants and record them in the DB:
|
-- * Send extension-Grants and record them in the DB:
|
||||||
-- * To each of my direct collaborators
|
-- * To each of my direct collaborators
|
||||||
-- * To each of my parents
|
-- * To each of my parents
|
||||||
|
-- * To each of my teams
|
||||||
--
|
--
|
||||||
-- * Option 4 - Almost-Parent sending me the delegator-Grant
|
-- * Option 4 - Almost-Parent sending me the delegator-Grant
|
||||||
-- * Update the Dest record, enabling the parent
|
-- * 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
|
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
|
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
--insert_ $ ComponentFurtherLocal enableID delegID extID
|
insert_ $ ComponentGather enableID startID extID
|
||||||
ext@(actionExt, _, _, _) <-
|
ext@(actionExt, _, _, _) <-
|
||||||
prepareExtensionGrantForParent identForCheck (Left (parentID, grantID)) (min role role') startID
|
prepareExtensionGrantForParent identForCheck (Left (parentID, grantID)) (min role role') startID
|
||||||
let recipByKey = LocalActorProject projectID
|
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
|
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
|
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
--insert_ $ ComponentFurtherRemote enableID delegID extID
|
insert_ $ ComponentGather enableID startID extID
|
||||||
ext@(actionExt, _, _, _) <-
|
ext@(actionExt, _, _, _) <-
|
||||||
prepareExtensionGrantForParent identForCheck (Right (parentID, grantID)) (min role role') startID
|
prepareExtensionGrantForParent identForCheck (Right (parentID, grantID)) (min role role') startID
|
||||||
let recipByKey = LocalActorProject projectID
|
let recipByKey = LocalActorProject projectID
|
||||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
return (extID, ext)
|
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
|
return
|
||||||
( recipActorID
|
( recipActorID
|
||||||
, sieve
|
, sieve
|
||||||
, localExtensions ++ localExtensionsForParents
|
, localExtensions ++ localExtensionsForParents ++ localExtensionsForTeams
|
||||||
, remoteExtensions ++ remoteExtensionsForParents
|
, remoteExtensions ++ remoteExtensionsForParents ++ remoteExtensionsForTeams
|
||||||
, inboxItemID
|
, inboxItemID
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
@ -2803,6 +2861,68 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
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 (GKDelegationStart _) = lift mzero
|
||||||
tryCollab (GKDelegationExtend _ _) = lift mzero
|
tryCollab (GKDelegationExtend _ _) = lift mzero
|
||||||
tryCollab GKDelegator = do
|
tryCollab GKDelegator = do
|
||||||
|
|
@ -3275,10 +3395,67 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
return (extID, ext)
|
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
|
return
|
||||||
( recipActorID
|
( recipActorID
|
||||||
, localExtensions ++ localExtensionsForParents
|
, localExtensions ++ localExtensionsForParents ++ localExtensionsForTeams
|
||||||
, remoteExtensions ++ remoteExtensionsForParents
|
, remoteExtensions ++ remoteExtensionsForParents ++ remoteExtensionsForTeams
|
||||||
, inboxItemID
|
, inboxItemID
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
@ -3291,7 +3468,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
sendActivity
|
sendActivity
|
||||||
recipByID recipActorID localRecipsExt
|
recipByID recipActorID localRecipsExt
|
||||||
remoteRecipsExt fwdHostsExt extID actionExt
|
remoteRecipsExt fwdHostsExt extID actionExt
|
||||||
doneDB inboxItemID "Sent extensions to collabs & parents"
|
doneDB inboxItemID "Sent extensions to collabs & parents & teams"
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -3410,6 +3587,61 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
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 (GKDelegationStart _) = lift mzero
|
||||||
tryParent (GKDelegationExtend _ _) = lift mzero
|
tryParent (GKDelegationExtend _ _) = lift mzero
|
||||||
tryParent GKDelegator = do
|
tryParent GKDelegator = do
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue