S2S: Group: Grant: Extend Grants from my projects

src/Vervis/Actor/Group.hs

@@ -1763,7 +1763,7 @@ data GrantKind
 --      * Record the delegator-Grant in the Collab record in DB
 --      * Forward the Grant to my followers
 --      * For each project of mine J, prepare and send an
---        extension-Grant to A, and store it in the ??? record in DB
+--        extension-Grant to A, and store it in the Source record in DB
 --      * For each start-grant or extension-grant G that I received from a
 --        parent of mine, prepare and send an extension-Grant to A, and store
 --        it in the Source record in DB
@@ -1911,7 +1911,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
             for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
 
                 -- Record the delegator-Grant in the Collab record
-                (insertLeaf, uDeleg) <-
+                (insertLeaf, insertEffortLeafTo, uDeleg) <-
                     lift $ case (grantDB, bimap entityKey entityKey recip) of
                         (Left (grantActor, _, grantID), Left localID) -> do
                             delegID <- insert $ CollabDelegLocal enableID localID grantID
@@ -1923,6 +1923,8 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
                             return
                                 ( \ leafID ->
                                     insert_ $ SourceUsLeafToLocal leafID delegID
+                                , \ leafID ->
+                                    insert_ $ EffortUsLeafToLocal leafID delegID
                                 , encodeRouteHome delegR
                                 )
                         (Right (_, _, grantID), Right remoteID) -> do
@@ -1931,6 +1933,8 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
                             return
                                 ( \ leafID ->
                                     insert_ $ SourceUsLeafToRemote leafID delegID
+                                , \ leafID ->
+                                    insert_ $ EffortUsLeafToRemote leafID delegID
                                 , u
                                 )
                         _ -> error "groupGrant impossible 2"
@@ -1940,8 +1944,6 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
                 let sieve = makeRecipientSet [] [LocalStageGroupFollowers groupHash]
 
                 extensions <- lift $ do
-                    -- For each Project of mine, prepare a delegation-extension
-                    -- Grant
                     (uCollab, audCollab) <-
                         case recip of
                             Left (Entity _ (CollabRecipLocal _ personID)) -> do
@@ -1955,7 +1957,49 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
                                 ra <- getJust raID
                                 u@(ObjURI h lu) <- getRemoteActorURI ra
                                 return (u, AudRemote h [lu] [])
-                    fromProjects <- pure []
+                    -- For each Grant I got from a project, prepare a
+                    -- delegation-extension Grant
+                    l' <-
+                        fmap (map $ over _2 Left) $
+                        E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
+                            E.on $ accept E.^. EffortThemAcceptLocalId E.==. deleg E.^. EffortThemDelegateLocalEffort
+                            E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
+                            E.on $ topic E.^. EffortTopicLocalId E.==. accept E.^. EffortThemAcceptLocalTopic
+                            E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort
+                            E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
+                            return
+                                ( send E.^. EffortUsSendDelegatorId
+                                , deleg
+                                )
+                    r' <-
+                        fmap (map $ over _2 Right) $
+                        E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
+                            E.on $ accept E.^. EffortThemAcceptRemoteId E.==. deleg E.^. EffortThemDelegateRemoteEffort
+                            E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
+                            E.on $ topic E.^. EffortTopicRemoteId E.==. accept E.^. EffortThemAcceptRemoteTopic
+                            E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort
+                            E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
+                            return
+                                ( send E.^. EffortUsSendDelegatorId
+                                , deleg
+                                )
+                    fromProjects <- for (l' ++ r') $ \ (E.Value sendID, deleg) -> do
+                        extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                        leafID <- insert $ EffortUsLeaf sendID enableID extID
+                        case bimap entityKey entityKey deleg of
+                            Left fromID -> insert_ $ EffortUsLeafFromLocal leafID fromID
+                            Right fromID -> insert_ $ EffortUsLeafFromRemote leafID fromID
+                        insertEffortLeafTo leafID
+                        (AP.Doc h a, grant) <- getGrantActivityBody $ bimap (effortThemDelegateLocalGrant . entityVal) (effortThemDelegateRemoteGrant . entityVal) deleg
+                        uStart <-
+                            case AP.activityId a of
+                                Nothing -> error "EffortThemDelegate grant has no 'id'"
+                                Just lu -> pure $ ObjURI h lu
+                        ext@(actionExt, _, _, _) <-
+                            prepareExtensionGrantFromParentOrProject uCollab audCollab uDeleg uStart grant role enableID
+                        let recipByKey = LocalActorGroup groupID
+                        _luExt <- updateOutboxItem' recipByKey extID actionExt
+                        return (extID, ext)
 
                     -- For each Grant I got from a parent, prepare a
                     -- delegation-extension Grant
@@ -1998,7 +2042,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
                                 Nothing -> error "SourceThemDelegate grant has no 'id'"
                                 Just lu -> pure $ ObjURI h lu
                         ext@(actionExt, _, _, _) <-
-                            prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID
+                            prepareExtensionGrantFromParentOrProject uCollab audCollab uDeleg uStart grant role enableID
                         let recipByKey = LocalActorGroup groupID
                         _luExt <- updateOutboxItem' recipByKey extID actionExt
                         return (extID, ext)
@@ -2021,7 +2065,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
 
         where
 
-        prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID = do
+        prepareExtensionGrantFromParentOrProject uCollab audCollab uDeleg uStart grant role enableID = do
             encodeRouteHome <- getEncodeRouteHome
             encodeRouteLocal <- getEncodeRouteLocal
 
@@ -2485,8 +2529,48 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
                 _luStart <- lift $ updateOutboxItem' recipByKey startID actionStart
 
                 -- For each Project in me, prepare a delegation-extension Grant
-                localExtensions <- pure []
+                l' <-
-                remoteExtensions <- pure []
+                    lift $ fmap (map $ over _2 Left) $
+                    E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
+                        E.on $ accept E.^. EffortThemAcceptLocalId E.==. deleg E.^. EffortThemDelegateLocalEffort
+                        E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
+                        E.on $ topic E.^. EffortTopicLocalId E.==. accept E.^. EffortThemAcceptLocalTopic
+                        E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort
+                        E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
+                        return
+                            ( send E.^. EffortUsSendDelegatorId
+                            , deleg
+                            )
+                r' <-
+                    lift $ fmap (map $ over _2 Right) $
+                    E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
+                        E.on $ accept E.^. EffortThemAcceptRemoteId E.==. deleg E.^. EffortThemDelegateRemoteEffort
+                        E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
+                        E.on $ topic E.^. EffortTopicRemoteId E.==. accept E.^. EffortThemAcceptRemoteTopic
+                        E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort
+                        E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
+                        return
+                            ( send E.^. EffortUsSendDelegatorId
+                            , deleg
+                            )
+                fromProjects <- lift $ for (l' ++ r') $ \ (E.Value sendID, deleg) -> do
+                    extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+
+                    distributeID <- insert $ EffortUsDistribute sendID destStartID extID
+                    case bimap entityKey entityKey deleg of
+                        Left localID -> insert_ $ EffortUsDistributeFromLocal distributeID localID
+                        Right remoteID -> insert_ $ EffortUsDistributeFromRemote distributeID remoteID
+
+                    (AP.Doc h a, grant) <- getGrantActivityBody $ bimap (effortThemDelegateLocalGrant . entityVal) (effortThemDelegateRemoteGrant . entityVal) deleg
+                    uStart <-
+                        case AP.activityId a of
+                            Nothing -> error "EffortThemDelegate grant has no 'id'"
+                            Just lu -> pure $ ObjURI h lu
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrantFromParentOrProject uStart grant role destStartID
+                    let recipByKey = LocalActorGroup groupID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
 
                 -- For each Grant I got from a child, prepare a
                 -- delegation-extension Grant
@@ -2530,14 +2614,14 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
                             Nothing -> error "SourceThemDelegate grant has no 'id'"
                             Just lu -> pure $ ObjURI h lu
                     ext@(actionExt, _, _, _) <-
-                        prepareExtensionGrantFromParent uStart grant role destStartID
+                        prepareExtensionGrantFromParentOrProject uStart grant role destStartID
                     let recipByKey = LocalActorGroup groupID
                     _luExt <- updateOutboxItem' recipByKey extID actionExt
                     return (extID, ext)
 
                 return
                     ( recipActorID
-                    , (startID, start) : localExtensions ++ remoteExtensions ++ fromParents
+                    , (startID, start) : fromProjects ++ fromParents
                     , inboxItemID
                     )
 
@@ -2596,7 +2680,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
-        prepareExtensionGrantFromParent uStart grant role startID = do
+        prepareExtensionGrantFromParentOrProject uStart grant role startID = do
             encodeRouteHome <- getEncodeRouteHome
             encodeRouteLocal <- getEncodeRouteLocal