From 1d13d7a5513c038228ba78f6fe3b196b8bf13ca5 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 13 Mar 2024 00:10:50 +0200 Subject: [PATCH] S2S: Project: Grant: Implement child mode --- src/Vervis/Actor/Project.hs | 348 ++++++++++++++++++++++++++++++++++-- src/Vervis/Migration.hs | 12 ++ th/models | 6 +- 3 files changed, 352 insertions(+), 14 deletions(-) diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 6cb4110..cecccb5 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -1856,7 +1856,7 @@ projectFollow now recipProjectID verse follow = do data GrantKind = GKDelegationStart AP.Role - | GKDelegationExtend AP.Role + | GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI) | GKDelegator -- Meaning: An actor is granting access-to-some-resource to another actor @@ -1970,17 +1970,20 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do let adapt = maybe (Right Nothing) (either Left (Right . Just)) maybeMode <- withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (Left <$> tryComp capability grant') <|> - runExceptT (Right <$> tryCollab capability grant') + runExceptT (Left . Left <$> tryComp capability grant') <|> + runExceptT (Left . Right <$> tryCollab capability grant') <|> + runExceptT (Right <$> tryChild capability grant') mode <- fromMaybeE maybeMode "Not a relevant Grant that I'm aware of" case mode of - Left (role, enableID, ident, identForCheck) -> + Left (Left (role, enableID, ident, identForCheck)) -> handleComp role enableID ident identForCheck - Right (enableID, role, recip) -> + Left (Right (enableID, role, recip)) -> handleCollab enableID role recip + Right (role, sendID, topic) -> + handleChild role sendID topic where @@ -2005,12 +2008,12 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do (AP.RXRole r, True, AP.GatherAndConvey, Nothing) -> pure $ GKDelegationStart r (AP.RXRole r, False, AP.GatherAndConvey, Just _) -> - pure $ GKDelegationExtend r + pure $ GKDelegationExtend r resource (AP.RXDelegator, True, AP.Invoke, Nothing) -> pure GKDelegator _ -> throwE "A kind of Grant that I don't use" - tryComp _ (GKDelegationExtend _) = lift mzero + tryComp _ (GKDelegationExtend _ _) = lift mzero tryComp _ GKDelegator = lift mzero tryComp capability (GKDelegationStart role) = do -- Find the Component record from the capability @@ -2311,9 +2314,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) - tryCollab _ (GKDelegationStart _) = lift mzero - tryCollab _ (GKDelegationExtend _) = lift mzero - tryCollab capability GKDelegator = do + tryCollab _ (GKDelegationStart _) = lift mzero + tryCollab _ (GKDelegationExtend _ _) = lift mzero + tryCollab capability GKDelegator = do -- Find the Collab record from the capability Entity enableID (CollabEnable collabID _) <- lift $ do -- Capability isn't mine @@ -2594,6 +2597,331 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + tryChild capability gk = do + role <- + case gk of + GKDelegationStart role -> pure role + GKDelegationExtend role _ -> pure role + GKDelegator -> lift mzero + -- Find the Source record from the capability + Entity sendID (SourceUsSendDelegator sourceID _) <- lift $ do + -- Capability isn't mine + guard $ fst capability == LocalActorProject projectID + -- I don't have a Source with this capability + MaybeT $ getBy $ UniqueSourceUsSendDelegatorGrant $ snd capability + Source role' <- lift $ lift $ getJust sourceID + SourceHolderProject _ j <- + lift $ MaybeT $ getValBy $ UniqueSourceHolderProject sourceID + -- Found a Source for this Grant but it's not mine + lift $ guard $ j == projectID + topic <- do + t <- lift $ lift $ getSourceTopic sourceID + bitraverse + (bitraverse + pure + (\case + Left j -> pure j + Right _g -> error "I have a SourceTopic that is a Group" + ) + ) + pure + t + topicForCheck <- + lift $ lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + topic + unless (first LocalActorProject topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Capability's source and Grant author aren't the same actor" + return (min role role', sendID, topic) + + handleChild role sendID topic = do + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + topicWithAccept <- + lift $ + bitraverse + (\ (localID, jID) -> + (localID, jID,) <$> + getKeyByJust (UniqueSourceThemAcceptLocal localID) + ) + (\ (remoteID, aID) -> + (remoteID, aID,) <$> + getKeyByJust (UniqueSourceThemAcceptRemote remoteID) + ) + topic + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ grantDB -> do + + -- Record the delegation in DB + from <- case (grantDB, bimap (view _3) (view _3) topicWithAccept) of + (Left (_, _, grantID), Left localID) -> Left <$> do + mk <- lift $ insertUnique $ SourceThemDelegateLocal localID grantID + fromMaybeE mk "I already have such a SourceThemDelegateLocal" + (Right (_, _, grantID), Right remoteID) -> Right <$> do + mk <- lift $ insertUnique $ SourceThemDelegateRemote remoteID grantID + fromMaybeE mk "I already have such a SourceThemDelegateRemote" + _ -> error "projectGrant.child impossible" + + -- For each Collab in me, prepare a delegation-extension Grant + localCollabs <- + lift $ + E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do + E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable + E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId + E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID + return + ( collab E.^. CollabRole + , recipL E.^. CollabRecipLocalPerson + , deleg + ) + localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value personID, Entity delegID (CollabDelegLocal enableID _recipID grantID)) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + leafID <- insert $ SourceUsLeaf sendID enableID extID + case from of + Left localID -> insert_ $ SourceUsLeafFromLocal leafID localID + Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID + insert_ $ SourceUsLeafToLocal leafID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant (Left (personID, grantID)) (min role role') enableID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteCollabs <- + lift $ + E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do + E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable + E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId + E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID + return + ( collab E.^. CollabRole + , recipR E.^. CollabRecipRemoteActor + , deleg + ) + remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value raID, Entity delegID (CollabDelegRemote enableID _recipID grantID)) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + leafID <- insert $ SourceUsLeaf sendID enableID extID + case from of + Left localID -> insert_ $ SourceUsLeafFromLocal leafID localID + Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID + insert_ $ SourceUsLeafToRemote leafID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant (Right (raID, grantID)) (min role role') enableID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + -- 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 `E.InnerJoin` accept) -> do + E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest + 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 + , accept E.^. DestUsAcceptId + ) + localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + gatherID <- insert $ SourceUsGather sendID acceptID extID + case from of + Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID + Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID + insert_ $ SourceUsGatherToLocal gatherID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForParent (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 `E.InnerJoin` accept) -> do + E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest + 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 + , accept E.^. DestUsAcceptId + ) + remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + gatherID <- insert $ SourceUsGather sendID acceptID extID + case from of + Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID + Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID + insert_ $ SourceUsGatherToRemote gatherID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForParent (Right (parentID, grantID)) (min role role') (Right delegID) + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return + ( recipActorID + , localExtensions ++ localExtensionsForParents + , remoteExtensions ++ remoteExtensionsForParents + ) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, localExts, remoteExts) -> do + let recipByID = LocalActorProject projectID + lift $ for_ (localExts ++ remoteExts) $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Sent extensions to collabs & parents" + + where + + prepareExtensionGrant collab role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + uStart <- lift $ getActivityURI authorIdMsig + + (uCollab, audCollab, uDeleg) <- + case collab of + Left (personID, itemID) -> do + personHash <- encodeKeyHashid personID + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ PersonR personHash + , AudLocal [LocalActorPerson personHash] [] + , encodeRouteHome $ + PersonOutboxItemR personHash 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) + + enableHash <- encodeKeyHashid enableID + + let audience = [audCollab] + + (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 = 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) + + prepareExtensionGrantForParent 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) + + 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 = AP.grantContext grant + , 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) + -- 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/Migration.hs b/src/Vervis/Migration.hs index 3482b4c..ea71141 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3198,6 +3198,18 @@ changes hLocal ctx = insertMany_ $ map (PermitTopicExtendLocal565 sendID enableID . E.unValue) gs -- 570 , addEntities model_570_source_dest + -- 571 + , removeUnique' "SourceThemDelegateLocal" "" + -- 572 + , removeUnique' "SourceThemDelegateLocal" "Grant" + -- 573 + , removeUnique' "SourceThemDelegateRemote" "" + -- 574 + , removeUnique' "SourceThemDelegateRemote" "Grant" + -- 575 + , addUnique' "SourceThemDelegateLocal" "" ["source", "grant"] + -- 576 + , addUnique' "SourceThemDelegateRemote" "" ["source", "grant"] ] migrateDB diff --git a/th/models b/th/models index a299faa..e41ec76 100644 --- a/th/models +++ b/th/models @@ -1421,15 +1421,13 @@ SourceThemDelegateLocal source SourceThemAcceptLocalId grant OutboxItemId - UniqueSourceThemDelegateLocal source - UniqueSourceThemDelegateLocalGrant grant + UniqueSourceThemDelegateLocal source grant SourceThemDelegateRemote source SourceThemAcceptRemoteId grant RemoteActivityId - UniqueSourceThemDelegateRemote source - UniqueSourceThemDelegateRemoteGrant grant + UniqueSourceThemDelegateRemote source grant -- Witnesses that, seeing the delegation from them, I've sent an -- extension-Grant to a Dest of mine