From a36eda1e2b43e6db8457099d6e750225bdfbf494 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 20 Jun 2024 17:13:54 +0300 Subject: [PATCH] S2S: Group: Grant: Implement resource mode --- src/Vervis/Actor/Group.hs | 435 +++++++++++++++++++++++++++----------- 1 file changed, 311 insertions(+), 124 deletions(-) diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index e155404..b73468c 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -2510,11 +2510,11 @@ data GrantKind -- Meaning: An actor is granting access-to-some-resource to another actor -- Behavior: --- * Option 1 - Project sending me a delegation-start or delegation-extension +-- * Option 1 - Resource 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 ??? record in DB +-- * Store the Grant in the Effort record in DB -- * Send extension-Grants and record them in the DB: -- * To each of my direct collaborators -- * To each of my children @@ -2567,7 +2567,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do let adapt = maybe (Right Nothing) (either Left (Right . Just)) maybeMode <- withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (Left . Left <$> tryProject grant') <|> + runExceptT (Left . Left <$> tryResource grant') <|> runExceptT (Left . Right <$> tryCollab grant') <|> runExceptT (Right . Left <$> tryParent grant') <|> runExceptT (Right . Right <$> tryAlmostChild grant') @@ -2576,8 +2576,8 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do maybeMode "Not a relevant Grant that I'm aware of" case mode of - Left (Left ()) -> - handleProject + Left (Left (role, sendID, topic)) -> + handleResource role sendID topic Left (Right (enableID, role, recip)) -> handleCollab enableID role recip Right (Left (role, sendID, topic)) -> @@ -2630,9 +2630,198 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do pure GKDelegator _ -> throwE "A kind of Grant that I don't use" - tryProject _ = lift mzero + tryResource gk = do + capability <- checkCapability + role <- + case gk of + GKDelegationStart role -> pure role + GKDelegationExtend role _ -> pure role + GKDelegator -> lift mzero + -- Find the Effort record from the capability + Entity sendID (EffortUsSendDelegator effortID _) <- lift $ do + -- Capability isn't mine + guard $ fst capability == LocalActorGroup groupID + -- I don't have a Effort with this capability + MaybeT $ getBy $ UniqueEffortUsSendDelegatorGrant $ snd capability + Effort role' g <- lift $ lift $ getJust effortID + -- Found a Effort for this Grant but it's not mine + lift $ guard $ g == groupID + topic <- lift $ lift $ getEffortTopic effortID + topicForCheck <- + lift $ lift $ + bitraverse + (\ (_, resourceID) -> getLocalResource resourceID) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + topic + unless (first resourceToActor topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Capability's effort and Grant author aren't the same actor" + return (min role role', sendID, topic) - handleProject = done "handleProject" + handleResource role sendID topic = do + + uCap <- lift $ getActivityURI authorIdMsig + checkCapabilityBeforeExtending uCap (LocalActorGroup groupID) + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + resourceID <- lift $ groupResource <$> getJust groupID + Resource recipActorID <- lift $ getJust resourceID + recipActor <- lift $ getJust recipActorID + + topicWithAccept <- + lift $ + bitraverse + (\ (localID, rID) -> + (localID, rID,) <$> + getKeyByJust (UniqueEffortThemAcceptLocal localID) + ) + (\ (remoteID, aID) -> + (remoteID, aID,) <$> + getKeyByJust (UniqueEffortThemAcceptRemote remoteID) + ) + topic + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ (inboxItemID, 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 $ EffortThemDelegateLocal localID grantID + fromMaybeE mk "I already have such a EffortThemDelegateLocal" + (Right (_, _, grantID), Right remoteID) -> Right <$> do + mk <- lift $ insertUnique $ EffortThemDelegateRemote remoteID grantID + fromMaybeE mk "I already have such a EffortThemDelegateRemote" + _ -> error "groupGrant.resource impossible" + + -- For each Collab in me, prepare a delegation-extension Grant + localCollabs <- + lift $ + E.select $ E.from $ \ (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 $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab + E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID + 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 $ EffortUsLeaf sendID enableID extID + case from of + Left localID -> insert_ $ EffortUsLeafFromLocal leafID localID + Right remoteID -> insert_ $ EffortUsLeafFromRemote leafID remoteID + insert_ $ EffortUsLeafToLocal leafID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForCollab (Left (personID, grantID)) (min role role') enableID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteCollabs <- + lift $ + E.select $ E.from $ \ (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 $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab + E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID + 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 $ EffortUsLeaf sendID enableID extID + case from of + Left localID -> insert_ $ EffortUsLeafFromLocal leafID localID + Right remoteID -> insert_ $ EffortUsLeafFromRemote leafID remoteID + insert_ $ EffortUsLeafToRemote leafID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForCollab (Right (raID, grantID)) (min role role') enableID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + -- For each child of mine, prepare a delegation-extension Grant + localChildren <- + lift $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest + E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest + E.on $ topic E.^. DestTopicGroupTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic + E.on $ holder E.^. DestHolderGroupId E.==. topic E.^. DestTopicGroupHolder + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest + E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID + return + ( dest E.^. DestRole + , topic E.^. DestTopicGroupChild + , deleg E.^. DestThemSendDelegatorLocalId + , deleg E.^. DestThemSendDelegatorLocalGrant + , accept E.^. DestUsAcceptId + , start E.^. DestUsStartId + ) + localExtensionsForChildren <- lift $ for localChildren $ \ (E.Value role', E.Value childID, E.Value _delegID, E.Value grantID, E.Value _acceptID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + distributeID <- insert $ EffortUsDistribute sendID startID extID + case from of + Left localID -> insert_ $ EffortUsDistributeFromLocal distributeID localID + Right remoteID -> insert_ $ EffortUsDistributeFromRemote distributeID remoteID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForChild (Left (childID, grantID)) (min role role') startID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteChildren <- + lift $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest + 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.^. DestHolderGroupDest + E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID + return + ( dest E.^. DestRole + , topic E.^. DestTopicRemoteTopic + , deleg E.^. DestThemSendDelegatorRemoteId + , deleg E.^. DestThemSendDelegatorRemoteGrant + , accept E.^. DestUsAcceptId + , start E.^. DestUsStartId + ) + remoteExtensionsForChildren <- lift $ for remoteChildren $ \ (E.Value role', E.Value childID, E.Value _delegID, E.Value grantID, E.Value _acceptID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + distributeID <- insert $ EffortUsDistribute sendID startID extID + case from of + Left localID -> insert_ $ EffortUsDistributeFromLocal distributeID localID + Right remoteID -> insert_ $ EffortUsDistributeFromRemote distributeID remoteID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForChild (Right (childID, grantID)) (min role role') startID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return + ( recipActorID + , localExtensions ++ localExtensionsForChildren + , remoteExtensions ++ remoteExtensionsForChildren + , inboxItemID + ) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, localExts, remoteExts, inboxItemID) -> do + let recipByID = LocalActorGroup groupID + lift $ for_ (localExts ++ remoteExts) $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "[Resource] Sent extensions to collabs & children" tryCollab (GKDelegationStart _) = lift mzero tryCollab (GKDelegationExtend _ _) = lift mzero @@ -2972,7 +3161,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID insert_ $ SourceUsLeafToLocal leafID delegID ext@(actionExt, _, _, _) <- - prepareExtensionGrant (Left (personID, grantID)) (min role role') enableID + prepareExtensionGrantForCollab (Left (personID, grantID)) (min role role') enableID let recipByKey = LocalActorGroup groupID _luExt <- updateOutboxItem' recipByKey extID actionExt return (extID, ext) @@ -2997,7 +3186,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID insert_ $ SourceUsLeafToRemote leafID delegID ext@(actionExt, _, _, _) <- - prepareExtensionGrant (Right (raID, grantID)) (min role role') enableID + prepareExtensionGrantForCollab (Right (raID, grantID)) (min role role') enableID let recipByKey = LocalActorGroup groupID _luExt <- updateOutboxItem' recipByKey extID actionExt return (extID, ext) @@ -3079,121 +3268,6 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do remoteRecipsExt fwdHostsExt extID actionExt doneDB inboxItemID "[Parent] Sent extensions to collabs & children" - where - - prepareExtensionGrant collab role enableID = do - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal - - groupHash <- encodeKeyHashid groupID - 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 $ - GroupMemberLiveR groupHash enableHash - , Nothing - ) - , AP.grantStart = Just now - , AP.grantEnd = Nothing - , AP.grantAllows = AP.Invoke - , AP.grantDelegates = Just uStart - } - } - - return (action, recipientSet, remoteActors, fwdHosts) - - prepareExtensionGrantForChild child role startID = do - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal - - groupHash <- encodeKeyHashid groupID - uStart <- lift $ getActivityURI authorIdMsig - - (uChild, audChild, uDeleg) <- - case child of - Left (g, itemID) -> do - h <- encodeKeyHashid g - itemHash <- encodeKeyHashid itemID - return - ( encodeRouteHome $ GroupR h - , AudLocal [LocalActorGroup h] [] - , encodeRouteHome $ - GroupOutboxItemR 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 <- do - startHash <- encodeKeyHashid startID - return $ - GroupChildLiveR groupHash startHash - - let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audChild] - - 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 = uChild - , AP.grantResult = - Just (encodeRouteLocal resultR, Nothing) - , AP.grantStart = Just now - , AP.grantEnd = Nothing - , AP.grantAllows = AP.Distribute - , AP.grantDelegates = Just uStart - } - } - - return (action, recipientSet, remoteActors, fwdHosts) - tryAlmostChild (GKDelegationStart _) = lift mzero tryAlmostChild (GKDelegationExtend _ _) = lift mzero tryAlmostChild GKDelegator = do @@ -3494,6 +3568,119 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + prepareExtensionGrantForCollab collab role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + 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 $ + GroupMemberLiveR groupHash enableHash + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + prepareExtensionGrantForChild child role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + uStart <- lift $ getActivityURI authorIdMsig + + (uChild, audChild, uDeleg) <- + case child of + Left (g, itemID) -> do + h <- encodeKeyHashid g + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ GroupR h + , AudLocal [LocalActorGroup h] [] + , encodeRouteHome $ + GroupOutboxItemR 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 <- do + startHash <- encodeKeyHashid startID + return $ + GroupChildLiveR groupHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audChild] + + 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 = uChild + , AP.grantResult = + Just (encodeRouteLocal resultR, Nothing) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , 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 list