From 1c10d3fb0394f21e48b422fd1e6efefd96b6171a Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 13 Mar 2024 15:36:50 +0200 Subject: [PATCH] S2S: Project: Grant: Implement parent mode --- .../577_2024-03-13_component_gather.model | 15 + src/Vervis/Actor/Project.hs | 407 ++++++++++++++++-- src/Vervis/Migration.hs | 2 + src/Vervis/Migration/Entities.hs | 6 +- th/models | 25 +- 5 files changed, 419 insertions(+), 36 deletions(-) create mode 100644 migrations/577_2024-03-13_component_gather.model diff --git a/migrations/577_2024-03-13_component_gather.model b/migrations/577_2024-03-13_component_gather.model new file mode 100644 index 0000000..590965e --- /dev/null +++ b/migrations/577_2024-03-13_component_gather.model @@ -0,0 +1,15 @@ +ComponentGatherLocal + component ComponentEnableId + parent DestThemSendDelegatorLocalId + grant OutboxItemId + + UniqueComponentGatherLocal component parent + UniqueComponentGatherLocalGrant grant + +ComponentGatherRemote + component ComponentEnableId + parent DestThemSendDelegatorRemoteId + grant OutboxItemId + + UniqueComponentGatherRemote component parent + UniqueComponentGatherRemoteGrant grant diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index cecccb5..00fe01e 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -1946,33 +1946,14 @@ projectGrant -> ActE (Text, Act (), Next) projectGrant now projectID (Verse authorIdMsig body) grant = do - -- Check capability - capability <- do - - -- Verify that a capability is provided - uCap <- do - let muCap = AP.activityCapability $ actbActivity body - fromMaybeE muCap "No capability provided" - - -- Verify the capability URI is one of: - -- * Outbox item URI of a local actor, i.e. a local activity - -- * A remote URI - cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap - - -- Verify the capability is local - case cap of - Left (actorByKey, _, outboxItemID) -> - return (actorByKey, outboxItemID) - _ -> throwE "Capability is remote i.e. definitely not by me" - - -- Check grant grant' <- checkGrant grant let adapt = maybe (Right Nothing) (either Left (Right . Just)) maybeMode <- withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (Left . Left <$> tryComp capability grant') <|> - runExceptT (Left . Right <$> tryCollab capability grant') <|> - runExceptT (Right <$> tryChild capability grant') + runExceptT (Left . Left <$> tryComp grant') <|> + runExceptT (Left . Right <$> tryCollab grant') <|> + runExceptT (Right . Left <$> tryChild grant') <|> + runExceptT (Right . Right <$> tryParent grant') mode <- fromMaybeE maybeMode @@ -1982,11 +1963,30 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do handleComp role enableID ident identForCheck Left (Right (enableID, role, recip)) -> handleCollab enableID role recip - Right (role, sendID, topic) -> + Right (Left (role, sendID, topic)) -> handleChild role sendID topic + Right (Right (role, topic, acceptID)) -> + handleParent role topic acceptID where + checkCapability = do + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + cap <- nameExceptT "Grant capability" $ parseActivityURI' uCap + + -- Verify the capability is local + case cap of + Left (actorByKey, _, outboxItemID) -> + return (actorByKey, outboxItemID) + _ -> throwE "Capability is remote i.e. definitely not by me" + checkGrant g = do (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- parseGrant' g @@ -2013,9 +2013,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do pure GKDelegator _ -> throwE "A kind of Grant that I don't use" - tryComp _ (GKDelegationExtend _ _) = lift mzero - tryComp _ GKDelegator = lift mzero - tryComp capability (GKDelegationStart role) = do + tryComp (GKDelegationExtend _ _) = lift mzero + tryComp GKDelegator = lift mzero + tryComp (GKDelegationStart role) = do + capability <- ExceptT $ lift $ lift $ runExceptT checkCapability -- Find the Component record from the capability Entity enableID (ComponentEnable componentID _) <- lift $ do -- Capability isn't mine @@ -2314,9 +2315,10 @@ 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 GKDelegator = do + capability <- ExceptT $ lift $ lift $ runExceptT checkCapability -- Find the Collab record from the capability Entity enableID (CollabEnable collabID _) <- lift $ do -- Capability isn't mine @@ -2597,7 +2599,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) - tryChild capability gk = do + tryChild gk = do + capability <- ExceptT $ lift $ lift $ runExceptT checkCapability role <- case gk of GKDelegationStart role -> pure role @@ -2922,6 +2925,348 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + tryParent (GKDelegationStart _) = lift mzero + tryParent (GKDelegationExtend _ _) = lift mzero + tryParent GKDelegator = do + uFulfills <- + case AP.activityFulfills $ actbActivity body of + [] -> throwE "No fulfills" + [u] -> pure u + _ -> throwE "Multiple fulfills" + fulfills <- ExceptT $ lift $ lift $ runExceptT $ first (\ (a, _, i) -> (a, i)) <$> parseActivityURI' uFulfills + fulfillsDB <- ExceptT $ MaybeT $ either (Just . Left) (fmap Right) <$> runExceptT (getActivity fulfills) + -- Find the Dest record from the fulfills + destID <- + lift $ + case fulfillsDB of + Left (_, _, addID) -> + (do DestUsGestureLocal destID _ <- MaybeT $ getValBy $ UniqueDestUsGestureLocalActivity addID + _ <- MaybeT $ getBy $ UniqueDestOriginUs destID + return destID + ) + <|> + (do DestThemGestureLocal themID _ <- MaybeT $ getValBy $ UniqueDestThemGestureLocalAdd addID + DestOriginThem destID <- lift $ getJust themID + return destID + ) + Right addID -> + (do DestUsGestureRemote destID _ _ <- MaybeT $ getValBy $ UniqueDestUsGestureRemoteActivity addID + _ <- MaybeT $ getBy $ UniqueDestOriginUs destID + return destID + ) + <|> + (do DestThemGestureRemote themID _ _ <- MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd addID + DestOriginThem destID <- lift $ getJust themID + return destID + ) + -- Verify this Dest record is mine + DestHolderProject _ j <- lift $ MaybeT $ getValBy $ UniqueDestHolderProject destID + lift $ guard $ j == projectID + -- Verify the Grant sender is the Dest topic + topic <- do + t <- lift $ lift $ getDestTopic destID + bitraverse + (bitraverse + pure + (\case + Left j -> pure j + Right _g -> error "I have a DestTopic 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 "Dest topic and Grant author aren't the same actor" + -- Verify I sent my Accept + maybeMe <- lift $ lift $ getKeyBy $ UniqueDestUsAccept destID + meAcceptID <- fromMaybeE maybeMe "I haven't sent my Accept" + -- Verify I haven't yet seen a delegator-Grant from the parent + case bimap fst fst topic of + Left localID -> do + m <- lift $ lift $ getBy $ UniqueDestThemSendDelegatorLocalTopic localID + verifyNothingE m "Already have a DestThemSendDelegatorLocal" + Right remoteID -> do + m <- lift $ lift $ getBy $ UniqueDestThemSendDelegatorRemoteTopic remoteID + verifyNothingE m "Already have a DestThemSendDelegatorRemote" + Dest role <- lift $ lift $ getJust destID + return (role, topic, meAcceptID) + + handleParent role topic acceptID = do + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ grantDB -> do + + -- Record the delegator-Grant in DB + to <- case (grantDB, bimap fst fst topic) of + (Left (_, _, grantID), Left localID) -> Left <$> do + mk <- lift $ insertUnique $ DestThemSendDelegatorLocal acceptID localID grantID + fromMaybeE mk "I already have such a DestThemSendDelegatorLocal" + (Right (_, _, grantID), Right remoteID) -> Right <$> do + mk <- lift $ insertUnique $ DestThemSendDelegatorRemote acceptID remoteID grantID + fromMaybeE mk "I already have such a DestThemSendDelegatorRemote" + _ -> error "projectGrant.parent impossible" + + -- For each Component in me, prepare a delegation-extension Grant + localComponents <- + lift $ + E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return + ( deleg E.^. ComponentDelegateLocalGrant + , comp + , enable + ) + localExtensions <- lift $ for localComponents $ \ (E.Value startID, Entity componentID component, Entity enableID _) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + case to of + Left localID -> insert_ $ ComponentGatherLocal enableID localID extID + Right remoteID -> insert_ $ ComponentGatherRemote enableID remoteID extID + componentIdent <- do + i <- getComponentIdent componentID + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + i + uStart <- do + encodeRouteHome <- getEncodeRouteHome + c <- + case componentIdent of + Left ci -> hashComponent ci + Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible" + s <- encodeKeyHashid startID + return $ encodeRouteHome $ activityRoute (componentActor c) s + ext@(actionExt, _, _, _) <- + prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID to + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteComponents <- + lift $ + E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId + E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return + ( deleg E.^. ComponentDelegateRemoteGrant + , comp + , enable + ) + remoteExtensions <- lift $ for remoteComponents $ \ (E.Value startID, Entity componentID component, Entity enableID _) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + case to of + Left localID -> insert_ $ ComponentGatherLocal enableID localID extID + Right remoteID -> insert_ $ ComponentGatherRemote enableID remoteID extID + componentIdent <- do + i <- getComponentIdent componentID + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + i + uStart <- do + ra <- getJust startID + getRemoteActivityURI ra + ext@(actionExt, _, _, _) <- + prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID to + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + -- For each Grant I got from a child, prepare a + -- delegation-extension Grant + l <- + lift $ 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 <- + lift $ 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 <- lift $ for (l ++ r) $ \ (E.Value sendID, deleg) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + + gatherID <- insert $ SourceUsGather sendID acceptID extID + case bimap entityKey entityKey deleg of + Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID + Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID + case to of + Left localID -> insert_ $ SourceUsGatherToLocal gatherID localID + Right remoteID -> insert_ $ SourceUsGatherToRemote gatherID remoteID + + (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 uStart grant role to + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return + ( recipActorID + , localExtensions ++ remoteExtensions ++ fromChildren + ) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, exts) -> do + let recipByID = LocalActorProject projectID + lift $ for_ exts $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Sent extensions from components and children" + + where + + prepareExtensionGrant component uStart role enableID deleg = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + + uDeleg <- lift $ getActivityURI authorIdMsig + uComponent <- + case component of + Left c -> do + a <- componentActor <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + enableHash <- encodeKeyHashid enableID + + 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 = [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) + + prepareExtensionGrantFromChild uStart grant role to = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + 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?" + + uDeleg <- lift $ getActivityURI authorIdMsig + audParent <- lift $ makeAudSenderOnly authorIdMsig + uParent <- lift $ getActorURI authorIdMsig + + resultR <- + case to 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 = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole finalRole + , 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 ea71141..58ddbe0 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3210,6 +3210,8 @@ changes hLocal ctx = , addUnique' "SourceThemDelegateLocal" "" ["source", "grant"] -- 576 , addUnique' "SourceThemDelegateRemote" "" ["source", "grant"] + -- 577 + , addEntities model_577_component_gather ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index b40dee7..f4b2a2a 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2018, 2019, 2020, 2022, 2023 + - Written in 2018, 2019, 2020, 2022, 2023, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -68,6 +68,7 @@ module Vervis.Migration.Entities , model_552_collab_deleg , model_564_permit , model_570_source_dest + , model_577_component_gather ) where @@ -264,3 +265,6 @@ model_564_permit = $(schema "564_2023-11-22_permit") model_570_source_dest :: [Entity SqlBackend] model_570_source_dest = $(schema "570_2023-12-09_source_dest") + +model_577_component_gather :: [Entity SqlBackend] +model_577_component_gather = $(schema "577_2024-03-13_component_gather") diff --git a/th/models b/th/models index e41ec76..4ac34c2 100644 --- a/th/models +++ b/th/models @@ -1067,6 +1067,7 @@ ComponentEnable -- Witnesses that the component used the delegator Grant to send an admin -- delegation to the project, to extend the delegation further + ComponentDelegateLocal component ComponentLocalId grant OutboxItemId @@ -1074,8 +1075,6 @@ ComponentDelegateLocal UniqueComponentDelegateLocal component UniqueComponentDelegateLocalGrant grant --- Witnesses that the component used the delegator Grant to send an admin --- delegation to the project, to extend the delegation further ComponentDelegateRemote component ComponentRemoteId grant RemoteActivityId @@ -1085,6 +1084,7 @@ ComponentDelegateRemote -- Witnesses that the project has extended a given delegation to a given -- direct collaborator + ComponentFurtherLocal component ComponentEnableId collab CollabDelegLocalId @@ -1093,8 +1093,6 @@ ComponentFurtherLocal UniqueComponentFurtherLocal component collab UniqueComponentFurtherLocalGrant grant --- Witnesses that the project has extended a given delegation to a given --- direct collaborator ComponentFurtherRemote component ComponentEnableId collab CollabDelegRemoteId @@ -1103,6 +1101,25 @@ ComponentFurtherRemote UniqueComponentFurtherRemote component collab UniqueComponentFurtherRemoteGrant grant +-- Witnesses that the project has extended a given delegation to a given +-- parent + +ComponentGatherLocal + component ComponentEnableId + parent DestThemSendDelegatorLocalId + grant OutboxItemId + + UniqueComponentGatherLocal component parent + UniqueComponentGatherLocalGrant grant + +ComponentGatherRemote + component ComponentEnableId + parent DestThemSendDelegatorRemoteId + grant OutboxItemId + + UniqueComponentGatherRemote component parent + UniqueComponentGatherRemoteGrant grant + ------------------------------------------------------------------------------ -- Components, from component perspective ------------------------------------------------------------------------------