diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index d82bec1..864c146 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -23,6 +23,7 @@ module Vervis.Actor.Common , topicRemove , topicJoin , topicCreateMe + , componentGrant ) where @@ -1680,3 +1681,237 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now } return (action, recipientSet, remoteActors, fwdHosts) + +-- Meaning: An actor is granting access-to-some-resource to another actor +-- Behavior: +-- * If I approved an Add-to-project where I'm the component, and the +-- project is now giving me the delegator-Grant: +-- * Record this in the Stem record in DB +-- * Forward to my followers +-- * Start a delegation chain giving access-to-me, send this new Grant +-- to the project to distribute further, and use the delegator-Grant +-- as the capability +-- * To: Project +-- * CC: My followers, project followers +-- * If I approved an Invite-to-project where I'm the component, and the +-- project is now giving me the delegator-Grant: +-- * Record this in the Stem record in DB +-- * Forward to my followers +-- * Start a delegation chain giving access-to-me, send this new Grant +-- to the project to distribute further, and use the delegator-Grant +-- as the capability +-- * To: Project +-- * CC: My followers, project followers +-- * If the Grant is for an Add/Invite that hasn't had the full approval +-- chain, or I already got the delegator-Grant, raise an error +-- * Otherwise, if I've already seen this Grant or it's simply not related +-- to me, ignore it +componentGrant + :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + => (topic -> ActorId) + -> (forall f. f topic -> GrantResourceBy f) + -> (forall f. f topic -> ComponentBy f) + -> UTCTime + -> Key topic + -> Verse + -> AP.Grant URIMode + -> ActE (Text, Act (), Next) +componentGrant grabActor topicResource topicComponent now recipKey (Verse authorIdMsig body) grant = do + + -- Check grant + project <- checkDelegatorGrant grant + + -- Check the Add/Invite that it's related to + fulfills <- + case AP.activityFulfills $ actbActivity body of + [u] -> + first (\ (actor, _, item) -> (actor, item)) <$> + nameExceptT "Grant.fulfills" (parseActivityURI' u) + _ -> throwE "Expecting a single 'fulfills' URI" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust recipKey + let actorID = grabActor recip + (actorID,) <$> getJust actorID + + -- Find the fulfilled activity in our DB + fulfillsDB <- do + a <- getActivity fulfills + fromMaybeE a "Can't find fulfilled in DB" + + -- See if the fulfilled activity is an Invite or Add on a local + -- component, grabbing the Stem record from our DB + stem <- do + maybeStem <- + lift $ runMaybeT $ + Left <$> tryInviteComp fulfillsDB <|> + Right <$> tryAddComp fulfillsDB + fromMaybeE maybeStem "Fulfilled activity isn't an Invite/Add I'm aware of" + + -- Find the local component and verify it's me + let stemID = either id id stem + ident <- lift $ getStemIdent stemID + unless (topicComponent recipKey == ident) $ + throwE "Fulfilled object is an Invite/Add for some other component" + + -- Find the project, verify it's identical to the Grant sender + stemProject <- + lift $ + requireEitherAlt + (getBy $ UniqueStemProjectLocal stemID) + (getBy $ UniqueStemProjectRemote stemID) + "Found Stem with no project" + "Found Stem with multiple projects" + case (stemProject, authorIdMsig) of + (Left (Entity _ sjl), Left (LocalActorProject projectID, _, _)) + | stemProjectLocalProject sjl == projectID -> + return () + (Right (Entity _ sjr), Right (author, _, _)) + | stemProjectRemoteProject sjr == remoteAuthorId author -> + return () + _ -> throwE "The Grant I'm waiting for is by the project" + + -- Verify I sent the Component's Accept but haven't already received + -- the delegator-Grant + compAccept <- do + mk <- lift $ getKeyBy $ UniqueStemComponentAccept stemID + fromMaybeE mk "Getting a delegator-Grant but never approved this Invite/Add" + gl <- lift $ getBy $ UniqueStemProjectGrantLocal compAccept + gr <- lift $ getBy $ UniqueStemProjectGrantRemote compAccept + unless (isNothing gl && isNothing gr) $ + throwE "I already received a delegator-Grant for this Invite/Add" + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + lift $ for maybeGrantDB $ \ grantDB -> do + + -- Prepare forwarding to my followers + sieve <- do + recipHash <- encodeKeyHashid recipKey + let recipByHash = + grantResourceLocalActor $ topicResource recipHash + return $ makeRecipientSet [] [localActorFollowers recipByHash] + + -- Update the Stem record in DB + case (stemProject, grantDB) of + (Left (Entity j _), Left (_, _, g)) -> insert_ $ StemProjectGrantLocal compAccept j g + (Right (Entity j _), Right (_, _, g)) -> insert_ $ StemProjectGrantRemote compAccept j g + _ -> error "componentGrant impossible" + chainID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ StemDelegateLocal compAccept chainID + + -- Prepare a Grant activity and insert to my outbox + chain <- do + Stem role <- getJust stemID + chain@(actionChain, _, _, _) <- prepareChain role + let recipByKey = grantResourceLocalActor $ topicResource recipKey + _luChain <- updateOutboxItem' recipByKey chainID actionChain + return chain + + return (recipActorID, sieve, chainID, chain) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do + let recipByID = grantResourceLocalActor $ topicResource recipKey + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ sendActivity + recipByID recipActorID localRecipsChain remoteRecipsChain + fwdHostsChain chainID actionChain + done "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant" + + where + + checkDelegatorGrant g = do + (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- + parseGrant' g + case role of + AP.RXRole _ -> throwE "Not a delegator Grant" + AP.RXDelegator -> pure () + project <- + bitraverse + (\case + GrantResourceProject j -> return j + _ -> throwE "Resource isn't a project" + ) + pure + resource + case (project, authorIdMsig) of + (Left j, Left (a, _, _)) | LocalActorProject j == a -> pure () + (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure () + _ -> throwE "Author and resource aren't the same project actor" + case recipient of + Left (GrantRecipComponent' c) + | topicComponent recipKey == c -> pure () + _ -> throwE "Grant recipient isn't me" + for_ mstart $ \ start -> + unless (start < now) $ throwE "Start time is in the future" + for_ mend $ \ _ -> + throwE "End time is specified" + unless (usage == AP.Invoke) $ + throwE "Usage isn't Invoke" + for_ mdeleg $ \ _ -> + throwE "'delegates' is specified" + return project + + tryInviteComp (Left (_, _, itemID)) = do + originInviteID <- + stemProjectGestureLocalOrigin <$> + MaybeT (getValBy $ UniqueStemProjectGestureLocalInvite itemID) + lift $ stemOriginInviteStem <$> getJust originInviteID + tryInviteComp (Right remoteActivityID) = do + StemProjectGestureRemote originInviteID _ _ <- + MaybeT $ getValBy $ + UniqueStemProjectGestureRemoteInvite remoteActivityID + lift $ stemOriginInviteStem <$> getJust originInviteID + + tryAddComp (Left (_, __, itemID)) = do + StemComponentGestureLocal stemID _ <- + MaybeT $ getValBy $ UniqueStemComponentGestureLocalActivity itemID + _originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID + return stemID + tryAddComp (Right remoteActivityID) = do + StemComponentGestureRemote stemID _ _ <- + MaybeT $ getValBy $ + UniqueStemComponentGestureRemoteActivity remoteActivityID + _originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID + return stemID + + prepareChain role = do + encodeRouteHome <- getEncodeRouteHome + + audProject <- makeAudSenderWithFollowers authorIdMsig + audMe <- + AudLocal [] . pure . localActorFollowers . + grantResourceLocalActor . topicResource <$> + encodeKeyHashid recipKey + uProject <- lift $ getActorURI authorIdMsig + uGrant <- lift $ getActivityURI authorIdMsig + recipHash <- encodeKeyHashid recipKey + let topicByHash = grantResourceLocalActor $ topicResource recipHash + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audProject, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uGrant + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uGrant] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = + encodeRouteHome $ renderLocalActor topicByHash + , AP.grantTarget = uProject + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.GatherAndConvey + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index fdcd737..32b139e 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -495,6 +495,38 @@ deckJoin = deckActor GrantResourceDeck CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck +-- Meaning: An actor is granting access-to-some-resource to another actor +-- Behavior: +-- * If I approved an Add-to-project where I'm the component, and the +-- project is now giving me the delegator-Grant: +-- * Record this in the Stem record in DB +-- * Forward to my followers +-- * Start a delegation chain giving access-to-me, send this new Grant +-- to the project to distribute further, and use the delegator-Grant +-- as the capability +-- * To: Project +-- * CC: My followers, project followers +-- * If I approved an Invite-to-project where I'm the component, and the +-- project is now giving me the delegator-Grant: +-- * Record this in the Stem record in DB +-- * Forward to my followers +-- * Start a delegation chain giving access-to-me, send this new Grant +-- to the project to distribute further, and use the delegator-Grant +-- as the capability +-- * To: Project +-- * CC: My followers, project followers +-- * If the Grant is for an Add/Invite that hasn't had the full approval +-- chain, or I already got the delegator-Grant, raise an error +-- * Otherwise, if I've already seen this Grant or it's simply not related +-- to me, ignore it +deckGrant + :: UTCTime + -> DeckId + -> Verse + -> AP.Grant URIMode + -> ActE (Text, Act (), Next) +deckGrant = componentGrant deckActor GrantResourceDeck ComponentDeck + ------------------------------------------------------------------------------ -- Ambiguous: Following/Resolving ------------------------------------------------------------------------------ @@ -711,6 +743,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) = AP.AddActivity add -> deckAdd now deckID verse add AP.CreateActivity create -> deckCreate now deckID verse create AP.FollowActivity follow -> deckFollow now deckID verse follow + AP.GrantActivity grant -> deckGrant now deckID verse grant AP.InviteActivity invite -> deckInvite now deckID verse invite AP.JoinActivity join -> deckJoin now deckID verse join AP.RejectActivity reject -> deckReject now deckID verse reject diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index e58b68a..56861e2 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -580,18 +580,21 @@ resourceToComponent = \case data GrantRecipBy' f = GrantRecipPerson' (f Person) | GrantRecipProject' (f Project) + | GrantRecipComponent' (ComponentBy f) deriving (Generic, FunctorB, TraversableB, ConstraintsB) deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f) parseGrantRecip' (PersonR p) = Just $ GrantRecipPerson' p parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j -parseGrantRecip' _ = Nothing +parseGrantRecip' r = GrantRecipComponent' <$> parseComponent r hashGrantRecip' (GrantRecipPerson' k) = GrantRecipPerson' <$> WAP.encodeKeyHashid k hashGrantRecip' (GrantRecipProject' k) = GrantRecipProject' <$> WAP.encodeKeyHashid k +hashGrantRecip' (GrantRecipComponent' byk) = + GrantRecipComponent' <$> hashComponent byk unhashGrantRecipPure' ctx = f where @@ -599,6 +602,8 @@ unhashGrantRecipPure' ctx = f GrantRecipPerson' <$> decodeKeyHashidPure ctx p f (GrantRecipProject' p) = GrantRecipProject' <$> decodeKeyHashidPure ctx p + f (GrantRecipComponent' c) = + GrantRecipComponent' <$> unhashComponentPure ctx c unhashGrantRecip' resource = do ctx <- asksEnv WAP.stageHashidsContext