S2S: Project: Grant: When adding component/child, extend Grant to teams

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
+                    , localExtensions ++ localExtensionsForParents ++ localExtensionsForTeams
-                    , remoteExtensions ++ remoteExtensionsForParents
+                    , 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
+                    , localExtensions ++ localExtensionsForParents ++ localExtensionsForTeams
-                    , remoteExtensions ++ remoteExtensionsForParents
+                    , 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