From 3359974af7267ca3a7ad24e0debfdc1bbf3e67e8 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 26 Jun 2024 19:20:38 +0300 Subject: [PATCH] S2S: Project: Grant: Implement team mode --- src/Vervis/Actor/Project.hs | 387 +++++++++++++++++++++++++++++++++++- 1 file changed, 381 insertions(+), 6 deletions(-) diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 01b794b..93c85ea 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -2910,6 +2910,13 @@ data GrantKind -- * For each grant I've been delegated from my children, send an -- extension-Grant to the new parent -- +-- * Option 5 - Almost-Team sending me the delegator-Grant +-- * Update the Squad record, enabling the team +-- * Send a start-Grant giving access-to-me +-- * For each of my components, send an extension-Grant to the team +-- * For each grant I've been delegated from my children, send an +-- extension-Grant to the team +-- -- * If neither of those, raise an error projectGrant :: UTCTime @@ -2922,11 +2929,17 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do grant' <- checkGrant grant let adapt = maybe (Right Nothing) (either Left (Right . Just)) maybeMode <- - withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (Left . Left <$> tryComp grant') <|> - runExceptT (Left . Right <$> tryCollab grant') <|> - runExceptT (Right . Left <$> tryChild grant') <|> - runExceptT (Right . Right <$> tryParent grant') + withDBExcept $ do + (_myInboxID, meResourceID) <- lift $ do + project <- getJust projectID + actor <- getJust $ projectActor project + return (actorInbox actor, projectResource project) + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left . Left <$> tryComp grant') <|> + runExceptT (Left . Right <$> tryCollab grant') <|> + runExceptT (Right . Left <$> tryChild grant') <|> + runExceptT (Right . Right . Left <$> tryParent grant') <|> + runExceptT (Right . Right . Right <$> tryTeam meResourceID grant') mode <- fromMaybeE maybeMode @@ -2938,8 +2951,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do handleCollab enableID role recip Right (Left (role, sendID, topic)) -> handleChild role sendID topic - Right (Right (role, topic, acceptID)) -> + Right (Right (Left (role, topic, acceptID))) -> handleParent role topic acceptID + Right (Right (Right (role, topic, acceptID))) -> + handleTeam role topic acceptID where @@ -4487,6 +4502,366 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) + tryTeam _ (GKDelegationStart _) = lift mzero + tryTeam _ (GKDelegationExtend _ _) = lift mzero + tryTeam meResourceID 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 Squad record from the fulfills + squadID <- + lift $ + case fulfillsDB of + Left (_, _, addID) -> + (do SquadUsGestureLocal squadID _ <- MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity addID + _ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID + return squadID + ) + <|> + (do SquadThemGestureLocal themID _ <- MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd addID + SquadOriginThem squadID <- lift $ getJust themID + return squadID + ) + Right addID -> + (do SquadUsGestureRemote squadID _ _ <- MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity addID + _ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID + return squadID + ) + <|> + (do SquadThemGestureRemote themID _ _ <- MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd addID + SquadOriginThem squadID <- lift $ getJust themID + return squadID + ) + -- Verify this Squad record is mine + Squad role r <- lift $ lift $ getJust squadID + lift $ guard $ r == meResourceID + -- Verify the Grant sender is the Squad topic + topic <- lift $ lift $ getSquadTeam squadID + topicForCheck <- + lift $ lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + topic + unless (first LocalActorGroup topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Squad topic and Grant author aren't the same actor" + -- Verify I sent my Accept + maybeMe <- lift $ lift $ getKeyBy $ UniqueSquadUsAccept squadID + meAcceptID <- fromMaybeE maybeMe "I haven't sent my Accept" + -- Verify I haven't yet seen a delegator-Grant from the team + case bimap fst fst topic of + Left localID -> do + m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorLocalTopic localID + verifyNothingE m "Already have a SquadThemSendDelegatorLocal" + Right remoteID -> do + m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorRemoteTopic remoteID + verifyNothingE m "Already have a SquadThemSendDelegatorRemote" + return (role, topic, meAcceptID) + + handleTeam 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 $ \ (inboxItemID, 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 $ SquadThemSendDelegatorLocal acceptID localID grantID + fromMaybeE mk "I already have such a SquadThemSendDelegatorLocal" + (Right (_, _, grantID), Right remoteID) -> Right <$> do + mk <- lift $ insertUnique $ SquadThemSendDelegatorRemote acceptID remoteID grantID + fromMaybeE mk "I already have such a SquadThemSendDelegatorRemote" + _ -> error "projectGrant.team impossible" + + startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + squadStartID <- lift $ insert $ SquadUsStart acceptID startID + + -- Prepare a start-Grant + start@(actionStart, _, _, _) <- lift $ prepareStartGrant role squadStartID + let recipByKey = LocalActorProject projectID + _luStart <- lift $ updateOutboxItem' recipByKey startID actionStart + + -- 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 + insert_ $ ComponentConvey enableID squadStartID 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 (resourceToActor $ componentResource c) s + ext@(actionExt, _, _, _) <- + prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID squadStartID + 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 + insert_ $ ComponentConvey enableID squadStartID 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 squadStartID + 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 + + conveyID <- insert $ SourceUsConvey sendID squadStartID extID + case bimap entityKey entityKey deleg of + Left localID -> insert_ $ SourceUsConveyFromLocal conveyID localID + Right remoteID -> insert_ $ SourceUsConveyFromRemote conveyID 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 squadStartID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return + ( recipActorID + , (startID, start) : localExtensions ++ remoteExtensions ++ fromChildren + , inboxItemID + ) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, exts, inboxItemID) -> do + let recipByID = LocalActorProject projectID + lift $ for_ exts $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "[Team] Sent start-Grant and extensions from components and children" + + where + + prepareExtensionGrant component uStart role enableID startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + + uDeleg <- lift $ getActivityURI authorIdMsig + uComponent <- + case component of + Left c -> do + a <- resourceToActor . componentResource <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + enableHash <- encodeKeyHashid enableID + + audTeam <- lift $ makeAudSenderOnly authorIdMsig + uTeam <- lift $ getActorURI authorIdMsig + + resultR <- do + startHash <- encodeKeyHashid startID + return $ ProjectTeamLiveR projectHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTeam] + + 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 = uTeam + , 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) + + prepareStartGrant role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + + uDeleg <- lift $ getActivityURI authorIdMsig + + audTeam <- lift $ makeAudSenderOnly authorIdMsig + uTeam <- lift $ getActorURI authorIdMsig + + resultR <- do + startHash <- encodeKeyHashid startID + return $ ProjectTeamLiveR projectHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTeam] + + 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 = uTeam + , AP.grantResult = + Just + ( encodeRouteLocal resultR + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + prepareExtensionGrantFromChild uStart grant role startID = 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 + audTeam <- lift $ makeAudSenderOnly authorIdMsig + uTeam <- lift $ getActorURI authorIdMsig + + resultR <- do + startHash <- encodeKeyHashid startID + return $ ProjectTeamLiveR projectHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTeam] + + 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 = uTeam + , 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 or components list