From 4838a131b427d05e5882c03be26e5931396baea3 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 27 May 2024 09:18:33 +0300 Subject: [PATCH] S2S: Group: Grant: Extend Grants from my projects --- src/Vervis/Actor/Group.hs | 108 +++++++++++++++++++++++++++++++++----- 1 file changed, 96 insertions(+), 12 deletions(-) diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index f3cad47..3a12789 100644 --- a/src/Vervis/Actor/Group.hs +++ b/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 [] - remoteExtensions <- pure [] + l' <- + 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