From 02f46a21f97df030f9ba822fd107783dfb90ef49 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 1 Jul 2024 15:54:12 +0300 Subject: [PATCH] S2S: Component: Grant: Port team-mode from Project --- src/Vervis/Actor/Common.hs | 141 ++++++++++++++++++++++++++++++++++++- 1 file changed, 139 insertions(+), 2 deletions(-) diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 96621e4..bb10a38 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -2208,13 +2208,15 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body withDBExcept $ do meResourceID <- lift $ grabResource <$> getJust recipKey ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (id <$> tryStem grant') + runExceptT (Left <$> tryStem grant') <|> + runExceptT (Right <$> tryTeam meResourceID grant') mode <- fromMaybeE maybeMode "Not a relevant Grant that I'm aware of" case mode of - stem -> handleStem stem + Left stem -> handleStem stem + Right team -> handleTeam team where @@ -2406,6 +2408,141 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body 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 + meResourceID <- lift $ grabResource <$> getJust meID + Resource meActorID <- lift $ getJust meResourceID + meActorDB <- lift $ getJust meActorID + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) 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 "componentGrant.team impossible" + + startID <- lift $ insertEmptyOutboxItem' (actorOutbox meActorDB) now + squadStartID <- lift $ insert $ SquadUsStart acceptID startID + + -- Prepare a start-Grant + start@(actionStart, _, _, _) <- lift $ prepareStartGrant role squadStartID + _luStart <- lift $ updateOutboxItem' meActor startID actionStart + + return (meActorID, startID, start, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt), inboxItemID) -> do + lift $ sendActivity + meActor recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "[Team] Sent start-Grant" + + where + + prepareStartGrant role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + meHash <- hashLocalActor meActor + + uDeleg <- lift $ getActivityURI authorIdMsig + + audTeam <- lift $ makeAudSenderOnly authorIdMsig + uTeam <- lift $ getActorURI authorIdMsig + + 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 $ renderLocalActor meHash + , AP.grantTarget = uTeam + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + -- Meaning: An actor is adding some object to some target -- Behavior: -- * If target is my context (i.e. parents) collection: