From 692c34bdec16b2c4c0a75b9fad0187bd15bcccab Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 13 Apr 2024 16:05:37 +0300 Subject: [PATCH] S2S: Project: Grant: When getting a new parent, send them a start-Grant This was accidentally not happening until now. If I, project A, send a start-Grant to my new parent project B, it means that whoever has access to project B will have access to my settings as well (for the specific operations their role allows). --- migrations/583_2024-04-13_dest_start.model | 6 ++ src/Vervis/Actor/Project.hs | 64 +++++++++++++++++++++- src/Vervis/Migration.hs | 2 + src/Vervis/Migration/Entities.hs | 4 ++ th/models | 10 ++++ 5 files changed, 84 insertions(+), 2 deletions(-) create mode 100644 migrations/583_2024-04-13_dest_start.model diff --git a/migrations/583_2024-04-13_dest_start.model b/migrations/583_2024-04-13_dest_start.model new file mode 100644 index 0000000..f33a133 --- /dev/null +++ b/migrations/583_2024-04-13_dest_start.model @@ -0,0 +1,6 @@ +DestUsStart + dest DestUsAcceptId + grant OutboxItemId + + UniqueDestUsStart dest + UniqueDestUsStartGrant grant diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index ee9e36c..534def9 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -2236,6 +2236,7 @@ data GrantKind -- -- * Option 4 - Almost-Parent sending me the delegator-Grant -- * Update the Dest record, enabling the parent +-- * Send a start-Grant giving access-to-me -- * 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 @@ -3324,6 +3325,14 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do fromMaybeE mk "I already have such a DestThemSendDelegatorRemote" _ -> error "projectGrant.parent impossible" + -- Prepare a start-Grant + startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + start@(actionStart, _, _, _) <- lift $ prepareStartGrant role to + let recipByKey = LocalActorProject projectID + _luStart <- lift $ updateOutboxItem' recipByKey startID actionStart + + lift $ insert_ $ DestUsStart acceptID startID + -- For each Component in me, prepare a delegation-extension Grant localComponents <- lift $ @@ -3446,7 +3455,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return ( recipActorID - , localExtensions ++ remoteExtensions ++ fromChildren + , (startID, start) : localExtensions ++ remoteExtensions ++ fromChildren ) case maybeNew of @@ -3458,7 +3467,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do sendActivity recipByID recipActorID localRecipsExt remoteRecipsExt fwdHostsExt extID actionExt - done "Sent extensions from components and children" + done "Sent start-Grant and extensions from components and children" where @@ -3519,6 +3528,55 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + prepareStartGrant role deleg = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + + uDeleg <- lift $ getActivityURI authorIdMsig + + audParent <- lift $ makeAudSenderOnly authorIdMsig + uParent <- lift $ getActorURI authorIdMsig + + 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 (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audParent] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uDeleg] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = encodeRouteHome $ ProjectR projectHash + , AP.grantTarget = uParent + , AP.grantResult = + Just + ( encodeRouteLocal resultR + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.GatherAndConvey + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + prepareExtensionGrantFromChild uStart grant role to = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal @@ -4571,6 +4629,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do deleteWhere [SourceUsGatherId <-. gatherIDs] -- Delete the whole Dest record + deleteBy $ UniqueDestUsStart usAcceptID case topic of Left (_, _, sendID) -> delete sendID Right (_, sendID) -> delete sendID @@ -4999,6 +5058,7 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus deleteWhere [SourceUsGatherId <-. gatherIDs] -- Delete the whole Dest record + deleteBy $ UniqueDestUsStart usAcceptID case send of Left sendID -> delete sendID Right sendID -> delete sendID diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 12d6666..b0cf609 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3222,6 +3222,8 @@ changes hLocal ctx = , addUnique' "SourceThemDelegateLocal" "" ["grant"] -- 582 , addUnique' "SourceThemDelegateRemote" "" ["grant"] + -- 583 + , addEntities model_583_dest_start ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 50daa12..f66647f 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -70,6 +70,7 @@ module Vervis.Migration.Entities , model_570_source_dest , model_577_component_gather , model_578_source_remove + , model_583_dest_start ) where @@ -272,3 +273,6 @@ model_577_component_gather = $(schema "577_2024-03-13_component_gather") model_578_source_remove :: [Entity SqlBackend] model_578_source_remove = $(schema "578_2024-04-03_source_remove") + +model_583_dest_start :: [Entity SqlBackend] +model_583_dest_start = $(schema "583_2024-04-13_dest_start") diff --git a/th/models b/th/models index ae10d2f..e00e10e 100644 --- a/th/models +++ b/th/models @@ -1684,3 +1684,13 @@ DestThemSendDelegatorRemote UniqueDestThemSendDelegatorRemote dest UniqueDestThemSendDelegatorRemoteTopic topic UniqueDestThemSendDelegatorRemoteGrant grant + +-- Witnesses that, seeing the delegator-Grant, I've sent my new parent a +-- start-Grant to delegate further + +DestUsStart + dest DestUsAcceptId + grant OutboxItemId + + UniqueDestUsStart dest + UniqueDestUsStartGrant grant