From 3570d502cbe53a7c5066ed6866b8f563cc5f3156 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 11 Mar 2024 12:50:15 +0200 Subject: [PATCH] S2S: Project: Grant: Child/parent delegation when adding collab/component --- migrations/570_2023-12-09_source_dest.model | 68 ++++-- src/Vervis/Actor/Project.hs | 257 +++++++++++++++++++- src/Vervis/Persist/Actor.hs | 18 +- src/Vervis/Persist/Collab.hs | 12 + th/models | 68 ++++-- 5 files changed, 376 insertions(+), 47 deletions(-) diff --git a/migrations/570_2023-12-09_source_dest.model b/migrations/570_2023-12-09_source_dest.model index f0f054e..e0095c0 100644 --- a/migrations/570_2023-12-09_source_dest.model +++ b/migrations/570_2023-12-09_source_dest.model @@ -164,36 +164,66 @@ SourceThemDelegateRemote -- Witnesses that, seeing the delegation from them, I've sent an -- extension-Grant to a Dest of mine -SourceUsGatherLocal - deleg SourceUsSendDelegatorId - dest DestThemSendDelegatorLocalId - grant OutboxItemId +SourceUsGather + source SourceUsSendDelegatorId + dest DestUsAcceptId + grant OutboxItemId - UniqueSourceUsGatherLocal grant +SourceUsGatherFromLocal + gather SourceUsGatherId + from SourceThemDelegateLocalId -SourceUsGatherRemote - deleg SourceUsSendDelegatorId - dest DestThemSendDelegatorRemoteId - grant RemoteActivityId + UniqueSourceUsGatherFromLocal gather - UniqueSourceUsGatherRemote grant +SourceUsGatherFromRemote + gather SourceUsGatherId + from SourceThemDelegateRemoteId + + UniqueSourceUsGatherFromRemote gather + +SourceUsGatherToLocal + gather SourceUsGatherId + to DestThemSendDelegatorLocalId + + UniqueSourceUsGatherToLocal gather + +SourceUsGatherToRemote + gather SourceUsGatherId + to DestThemSendDelegatorRemoteId + + UniqueSourceUsGatherToRemote gather -- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a -- direct-collaborator of mine -SourceUsLeafLocal - deleg SourceUsSendDelegatorId - collab CollabDelegLocalId +SourceUsLeaf + source SourceUsSendDelegatorId + collab CollabEnableId grant OutboxItemId - UniqueSourceUsLeafLocal grant +SourceUsLeafFromLocal + leaf SourceUsLeafId + from SourceThemDelegateLocalId -SourceUsLeafRemote - deleg SourceUsSendDelegatorId - collab CollabDelegRemoteId - grant RemoteActivityId + UniqueSourceUsLeafFromLocal leaf - UniqueSourceUsLeafRemote grant +SourceUsLeafFromRemote + leaf SourceUsLeafId + from SourceThemDelegateRemoteId + + UniqueSourceUsLeafFromRemote leaf + +SourceUsLeafToLocal + leaf SourceUsLeafId + to CollabDelegLocalId + + UniqueSourceUsLeafToLocal leaf + +SourceUsLeafToRemote + leaf SourceUsLeafId + to CollabDelegRemoteId + + UniqueSourceUsLeafToRemote leaf ------------------------------------------------------------------------------ -- Inheritance - Giver tracking her receivers diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 74f62f1..5580289 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -1871,13 +1871,20 @@ projectFollow now recipProjectID verse follow = do -- * Record the delegation in the Component record in DB -- * Forward the Grant to my followers -- * For each person (non-team) collaborator of mine, prepare and send an --- extension-Grant, and store it in the Componet record in DB: +-- extension-Grant, and store it in the Component record in DB: -- * Role: The lower among (1) admin (2) the collaborator's role in me -- * Resource: C -- * Target: The collaborator -- * Delegates: The Grant I just got from C -- * Result: ProjectCollabLiveR for this collaborator -- * Usage: invoke +-- * For each parent of mine, prepare and send an extension-Grant: +-- * Role: The lower among (1) the role the component gave me (2) the role I gave the parent +-- * Resource: C +-- * Target: The parent +-- * Delegates: The Grant I just got from C +-- * Result: ProjectParentLiveR for this parent +-- * Usage: gatherAndConvey -- -- * Option 2 - Collaborator sending me a delegator-Grant - Verify that: -- * The sender is a collaborator of mine, A @@ -1899,8 +1906,33 @@ projectFollow now recipProjectID verse follow = do -- * Delegates: The start-Grant I have from C -- * Result: ProjectCollabLiveR for this collaborator, A -- * Usage: invoke +-- * For each start-grant or extension-grant G that I received from a +-- child of mine J, prepare and send an extension-Grant to A, and store +-- it in the Source record in DB: +-- * Role: The lower among (1) the role in G (2) the collaborator's role in me +-- * Resource: The one specified in G +-- * Target: A +-- * Delegates: G +-- * Result: ProjectCollabLiveR for this collaborator, A +-- * Usage: invoke -- --- * If neither 1 nor 2, raise an error +-- * Option 3 - Child sending me a delegation-start or delegation-extension +-- * Verify they're authorized, i.e. they're using the delegator-Grant +-- I gave them +-- * Verify the role isn't delegator +-- * Store the Grant in the Source record in DB +-- * Send extension-Grants and record them in the DB: +-- * To each of my direct collaborators +-- * To each of my parents +-- +-- * Option 4 - Almost-Parent sending me the delegator-Grant +-- * Update the Dest record, enabling the parent +-- * For each of my components, send an extension-Grant to the new +-- parent +-- * For each grant I've been delegated from my children, send an +-- extension-Grant to the new parent +-- +-- * If neither of those, raise an error projectGrant :: UTCTime -> ProjectId @@ -2094,7 +2126,57 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do _luExt <- updateOutboxItem' recipByKey extID actionExt return (extID, ext) - return (recipActorID, sieve, localExtensions, remoteExtensions) + -- For each parent of mine, prepare a delegation-extension Grant + localParents <- + lift $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg) -> do + E.on $ topic E.^. DestTopicProjectTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic + E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest + E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID + return + ( dest E.^. DestRole + , topic E.^. DestTopicProjectParent + , deleg E.^. DestThemSendDelegatorLocalId + , deleg E.^. DestThemSendDelegatorLocalGrant + ) + localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + --insert_ $ ComponentFurtherLocal enableID delegID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForParent identForCheck (Left (parentID, grantID)) (min role role') (Left delegID) + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteParents <- + lift $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg) -> do + E.on $ topic E.^. DestTopicRemoteId E.==. deleg E.^. DestThemSendDelegatorRemoteTopic + E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest + E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID + return + ( dest E.^. DestRole + , topic E.^. DestTopicRemoteTopic + , deleg E.^. DestThemSendDelegatorRemoteId + , deleg E.^. DestThemSendDelegatorRemoteGrant + ) + remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + --insert_ $ ComponentFurtherRemote enableID delegID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForParent identForCheck (Right (parentID, grantID)) (min role role') (Right delegID) + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return + ( recipActorID + , sieve + , localExtensions ++ localExtensionsForParents + , remoteExtensions ++ remoteExtensionsForParents + ) case maybeNew of Nothing -> done "I already have this activity in my inbox" @@ -2175,6 +2257,76 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + prepareExtensionGrantForParent component parent role deleg = 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 $ ProjectR h + , AudLocal [LocalActorProject h] [] + , encodeRouteHome $ + ProjectOutboxItemR 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 <- componentActor <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + resultR <- + case deleg of + Left delegID -> do + delegHash <- encodeKeyHashid delegID + return $ + ProjectParentLocalLiveR projectHash delegHash + Right delegID -> do + delegHash <- encodeKeyHashid delegID + return $ + ProjectParentRemoteLiveR projectHash delegHash + + 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.GatherAndConvey + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + handleCollab capability collab = do maybeNew <- withDBExcept $ do @@ -2216,7 +2368,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do for maybeGrantDB $ \ grantDB -> do -- Record the delegator-Grant in the Collab record - (insertExt, uDeleg) <- + (insertExt, insertLeaf, uDeleg) <- lift $ case (grantDB, bimap entityKey entityKey recip) of (Left (grantActor, _, grantID), Left localID) -> do delegID <- insert $ CollabDelegLocal enableID localID grantID @@ -2228,6 +2380,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (\ enableID furtherID -> insert_ $ ComponentFurtherLocal enableID delegID furtherID + , \ leafID -> + insert_ $ SourceUsLeafToLocal leafID delegID , encodeRouteHome delegR ) (Right (_, _, grantID), Right remoteID) -> do @@ -2236,6 +2390,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (\ enableID furtherID -> insert_ $ ComponentFurtherRemote enableID delegID furtherID + , \ leafID -> + insert_ $ SourceUsLeafToRemote leafID delegID , u ) _ -> error "projectGrant impossible 2" @@ -2244,9 +2400,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do projectHash <- encodeKeyHashid projectID let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash] - -- For each Component of mine, prepare a delegation-extension - -- Grant extensions <- lift $ do + -- For each Component of mine, prepare a delegation-extension + -- Grant locals <- fmap (map $ over _1 Left) $ E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do @@ -2276,7 +2432,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do ra <- getJust raID u@(ObjURI h lu) <- getRemoteActorURI ra return (u, AudRemote h [lu] []) - for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID' _) -> do + fromComponents <- for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID' _) -> do extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now insertExt enableID' extID componentIdent <- do @@ -2304,6 +2460,54 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do _luExt <- updateOutboxItem' recipByKey extID actionExt return (extID, ext) + -- For each Grant I got from a child, prepare a + -- delegation-extension Grant + l <- + fmap (map $ over _2 Left) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do + E.on $ accept E.^. SourceThemAcceptLocalId E.==. deleg E.^. SourceThemDelegateLocalSource + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicLocalId E.==. accept E.^. SourceThemAcceptLocalTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicLocalSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource + E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID + return + ( send E.^. SourceUsSendDelegatorId + , deleg + ) + r <- + fmap (map $ over _2 Right) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do + E.on $ accept E.^. SourceThemAcceptRemoteId E.==. deleg E.^. SourceThemDelegateRemoteSource + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource + E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID + return + ( send E.^. SourceUsSendDelegatorId + , deleg + ) + fromChildren <- for (l ++ r) $ \ (E.Value sendID, deleg) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + leafID <- insert $ SourceUsLeaf sendID enableID extID + case bimap entityKey entityKey deleg of + Left fromID -> insert_ $ SourceUsLeafFromLocal leafID fromID + Right fromID -> insert_ $ SourceUsLeafFromRemote leafID fromID + insertLeaf leafID + (AP.Doc h a, grant) <- getGrantActivityBody $ bimap (sourceThemDelegateLocalGrant . entityVal) (sourceThemDelegateRemoteGrant . entityVal) deleg + uStart <- + case AP.activityId a of + Nothing -> error "SourceThemDelegate grant has no 'id'" + Just lu -> pure $ ObjURI h lu + ext@(actionExt, _, _, _) <- + prepareExtensionGrantFromChild uCollab audCollab uDeleg uStart grant role enableID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return $ fromComponents ++ fromChildren + return (recipActorID, sieve, extensions) case maybeNew of @@ -2363,6 +2567,45 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + prepareExtensionGrantFromChild uCollab audCollab uDeleg uStart grant role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + enableHash <- encodeKeyHashid enableID + finalRole <- + case AP.grantObject grant of + AP.RXRole r -> pure $ min role r + AP.RXDelegator -> error "Why was I delegated a Grant with object=delegator?" + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audCollab] + + 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 finalRole + , AP.grantContext = AP.grantContext grant + , AP.grantTarget = uCollab + , AP.grantResult = + Just + (encodeRouteLocal $ + ProjectCollabLiveR projectHash enableHash + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + -- Meaning: An actor A invited actor B to a resource -- Behavior: -- * Verify the resource is my collabs or components list diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 6cb052d..bb48db9 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022, 2023 by fr33domlover . + - Written in 2022, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -28,6 +28,7 @@ module Vervis.Persist.Actor , updateOutboxItem' , fillPerActorKeys , getPersonWidgetInfo + , getActivityBody ) where @@ -37,6 +38,7 @@ import Control.Monad.Logger.CallStack import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Reader +import Data.Aeson import Data.Barbie import Data.Bitraversable import Data.Text (Text) @@ -64,7 +66,6 @@ import qualified Web.Actor.Persist as WAP import Control.Monad.Trans.Except.Local import Database.Persist.Local ---import Vervis.Actor2 () import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation @@ -234,3 +235,16 @@ getPersonWidgetInfo = bitraverse getLocal getRemote remoteObject <- getJust $ remoteActorIdent remoteActor inztance <- getJust $ remoteObjectInstance remoteObject return (inztance, remoteObject, remoteActor) + +getActivityBody + :: Either OutboxItemId RemoteActivityId + -> VA.ActDB (AP.Doc AP.Activity URIMode) +getActivityBody k = do + obj <- + persistJSONDoc <$> + case k of + Left itemID -> outboxItemActivity <$> getJust itemID + Right itemID -> remoteActivityContent <$> getJust itemID + case fromJSON $ Object obj of + Error s -> error $ "Parsing activity " ++ show k ++ " failed: " ++ s + Success doc -> return doc diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 40ea274..43cce76 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -48,6 +48,8 @@ module Vervis.Persist.Collab , verifyNoStartedGroupChildren , verifyNoEnabledProjectParents , verifyNoEnabledGroupChildren + + , getGrantActivityBody ) where @@ -83,6 +85,7 @@ import Database.Persist.Local import Vervis.Actor import Vervis.Data.Collab +import Vervis.FedURI import Vervis.Model import Vervis.Persist.Actor @@ -1027,3 +1030,12 @@ verifyNoEnabledGroupChildren groupID destDB = do -- any are enabled, make sure there's at most one (otherwise it's a -- bug) verifyDestsNotEnabled destIDs + +getGrantActivityBody + :: Either OutboxItemId RemoteActivityId + -> ActDB (AP.Doc AP.Activity URIMode, AP.Grant URIMode) +getGrantActivityBody k = do + doc@(AP.Doc _ act) <- getActivityBody k + case AP.activitySpecific act of + AP.GrantActivity g -> return (doc, g) + _ -> error "Not a Grant activity" diff --git a/th/models b/th/models index ce21e56..a299faa 100644 --- a/th/models +++ b/th/models @@ -1434,36 +1434,66 @@ SourceThemDelegateRemote -- Witnesses that, seeing the delegation from them, I've sent an -- extension-Grant to a Dest of mine -SourceUsGatherLocal - deleg SourceUsSendDelegatorId - dest DestThemSendDelegatorLocalId - grant OutboxItemId +SourceUsGather + source SourceUsSendDelegatorId + dest DestUsAcceptId + grant OutboxItemId - UniqueSourceUsGatherLocal grant +SourceUsGatherFromLocal + gather SourceUsGatherId + from SourceThemDelegateLocalId -SourceUsGatherRemote - deleg SourceUsSendDelegatorId - dest DestThemSendDelegatorRemoteId - grant RemoteActivityId + UniqueSourceUsGatherFromLocal gather - UniqueSourceUsGatherRemote grant +SourceUsGatherFromRemote + gather SourceUsGatherId + from SourceThemDelegateRemoteId + + UniqueSourceUsGatherFromRemote gather + +SourceUsGatherToLocal + gather SourceUsGatherId + to DestThemSendDelegatorLocalId + + UniqueSourceUsGatherToLocal gather + +SourceUsGatherToRemote + gather SourceUsGatherId + to DestThemSendDelegatorRemoteId + + UniqueSourceUsGatherToRemote gather -- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a -- direct-collaborator of mine -SourceUsLeafLocal - deleg SourceUsSendDelegatorId - collab CollabDelegLocalId +SourceUsLeaf + source SourceUsSendDelegatorId + collab CollabEnableId grant OutboxItemId - UniqueSourceUsLeafLocal grant +SourceUsLeafFromLocal + leaf SourceUsLeafId + from SourceThemDelegateLocalId -SourceUsLeafRemote - deleg SourceUsSendDelegatorId - collab CollabDelegRemoteId - grant RemoteActivityId + UniqueSourceUsLeafFromLocal leaf - UniqueSourceUsLeafRemote grant +SourceUsLeafFromRemote + leaf SourceUsLeafId + from SourceThemDelegateRemoteId + + UniqueSourceUsLeafFromRemote leaf + +SourceUsLeafToLocal + leaf SourceUsLeafId + to CollabDelegLocalId + + UniqueSourceUsLeafToLocal leaf + +SourceUsLeafToRemote + leaf SourceUsLeafId + to CollabDelegRemoteId + + UniqueSourceUsLeafToRemote leaf ------------------------------------------------------------------------------ -- Inheritance - Giver tracking her receivers