From 06e5ab9e900fe3cfd1824e7ac5154b191eaffe3b Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 17 Jul 2023 20:57:19 +0300 Subject: [PATCH] S2S: Project Grant handler --- src/Vervis/API.hs | 6 +- src/Vervis/Actor/Common.hs | 4 +- src/Vervis/Actor/Project.hs | 256 +++++++++++++++++++++++++++++++++++- src/Vervis/Data/Collab.hs | 105 ++++++++++++++- src/Web/ActivityPub.hs | 6 +- 5 files changed, 366 insertions(+), 11 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index af73664..ffbe942 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -397,7 +397,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re , actionFulfills = [AP.acceptObject accept] , actionSpecific = GrantActivity Grant { grantObject = RoleAdmin - , grantContext = encodeRouteLocal $ renderLocalActor topicHash + , grantContext = encodeRouteHome $ renderLocalActor topicHash , grantTarget = encodeRouteHome $ PersonR recipHash , grantResult = Nothing , grantStart = Nothing @@ -1196,7 +1196,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant { grantObject = AP.RXRole RoleAdmin - , grantContext = encodeRouteLocal $ LoomR loomHash + , grantContext = encodeRouteHome $ LoomR loomHash , grantTarget = encodeRouteHome $ PersonR adminHash , grantResult = Nothing , grantStart = Nothing @@ -1432,7 +1432,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant { grantObject = AP.RXRole RoleAdmin - , grantContext = encodeRouteLocal $ RepoR repoHash + , grantContext = encodeRouteHome $ RepoR repoHash , grantTarget = encodeRouteHome $ PersonR adminHash , grantResult = Nothing , grantStart = Nothing diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 885c25f..ff67a8c 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -415,7 +415,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce , AP.actionSpecific = AP.GrantActivity AP.Grant { AP.grantObject = AP.RXRole role , AP.grantContext = - encodeRouteLocal $ renderLocalActor topicByHash + encodeRouteHome $ renderLocalActor topicByHash , AP.grantTarget = if isInvite then uAccepter @@ -1296,7 +1296,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now , AP.actionSpecific = AP.GrantActivity AP.Grant { AP.grantObject = AP.RXRole AP.RoleAdmin , AP.grantContext = - encodeRouteLocal $ renderLocalActor topicByHash + encodeRouteHome $ renderLocalActor topicByHash , AP.grantTarget = uCreator , AP.grantResult = Nothing , AP.grantStart = Just now diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 6154305..fa71ade 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -537,7 +537,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do , AP.actionSpecific = AP.GrantActivity AP.Grant { AP.grantObject = AP.RXRole role , AP.grantContext = - encodeRouteLocal $ renderLocalActor topicByHash + encodeRouteHome $ renderLocalActor topicByHash , AP.grantTarget = if isInvite then uAccepter @@ -594,7 +594,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do , AP.actionFulfills = [AP.acceptObject accept] , AP.actionSpecific = AP.GrantActivity AP.Grant { AP.grantObject = AP.RXDelegator - , AP.grantContext = encodeRouteLocal $ ProjectR projectHash + , AP.grantContext = encodeRouteHome $ ProjectR projectHash , AP.grantTarget = uComponent , AP.grantResult = Nothing , AP.grantStart = Just now @@ -877,6 +877,257 @@ projectFollow now recipProjectID verse follow = do (\ _ -> pure []) now recipProjectID verse follow +-- Meaning: An actor is granting access-to-some-resource to another actor +-- Behavior: +-- * Verify that: +-- * The sender is a component of mine, C +-- * The Grant's context is C +-- * The Grant's target is me +-- * The Grant's usage is gatherAndConvey +-- * The Grant doesn't specify 'delegates' +-- * The activity is authorized via a valid delegator-Grant I had sent +-- to C +-- * Verify the Grant's role is the same one specified in the Invite/Add +-- that added the Component +-- * Verify I don't yet have a delegation from C +-- * Insert the Grant to my inbox +-- * Record the delegation in the Component record in DB +-- * Forward the Grant to my followers +-- * For each person (non-team) collaborator of mine, prepare and send a +-- Grant, and store it in the Componet record in DB: +-- * Role: The lower among (1) admin (2) the collaborator's role in me +-- * Resource: C +-- * Target: The collaborator +-- * Delegates: The Grant I just got from C +-- * Result: ProjectCollabLiveR for this collaborator +-- * Usage: invoke +projectGrant + :: UTCTime + -> ProjectId + -> Verse + -> AP.Grant URIMode + -> 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 + (role, component) <- checkDelegationStart grant + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + -- Find the Component record from the capability + Entity enableID (ComponentEnable componentID _) <- do + unless (fst capability == LocalActorProject projectID) $ + throwE "Capability isn't mine" + m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability + fromMaybeE m "I don't have a Component with this capability" + Component j role' <- lift $ getJust componentID + unless (j == projectID) $ + throwE "Found a Component for this delegator-Grant but it's not mine" + unless (role' == role) $ + throwE "Grant role isn't the same as in the Invite/Add" + ident <- lift $ getComponentIdent componentID + identForCheck <- + lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + ident + unless (identForCheck == component) $ + throwE "Capability's component and Grant author aren't the same actor" + + -- Verify I don't yet have a delegation from the component + maybeDeleg <- + lift $ case bimap fst fst ident of + Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID) + verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component" + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ grantDB -> do + + -- Record the delegation in DB + lift $ case (grantDB, bimap fst fst ident) of + (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID + (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID + _ -> error "projectGrant impossible" + + -- Prepare forwarding of Accept to my followers + projectHash <- encodeKeyHashid projectID + let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash] + + -- For each Collab in me, prepare a delegation-extension Grant + localCollabs <- + lift $ + E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL) -> do + E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId + E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID + return + ( collab E.^. CollabRole + , recipL E.^. CollabRecipLocalId + , recipL E.^. CollabRecipLocalPerson + , enable E.^. CollabEnableId + ) + localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value recipID, E.Value personID, E.Value enableID') -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ ComponentFurtherLocal enableID recipID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant identForCheck (Left personID) (min role role') enableID' + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteCollabs <- + lift $ + E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR) -> do + E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId + E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID + return + ( collab E.^. CollabRole + , recipR E.^. CollabRecipRemoteId + , recipR E.^. CollabRecipRemoteActor + , enable E.^. CollabEnableId + ) + remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value recipID, E.Value raID, E.Value enableID') -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ ComponentFurtherRemote enableID recipID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant identForCheck (Right raID) (min role role') enableID' + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return (recipActorID, sieve, localExtensions, remoteExtensions) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, localExts, remoteExts) -> do + let recipByID = LocalActorProject projectID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ (localExts ++ remoteExts) $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Forwarded the Grant and published delegation extensions" + + where + + checkDelegationStart g = do + (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- + parseGrant' g + role' <- + case role of + AP.RXRole r -> pure r + AP.RXDelegator -> throwE "Role is delegator" + component <- + fromMaybeE + (bitraverse resourceToComponent Just resource) + "Resource is a local project, therefore not a component of mine" + case (component, authorIdMsig) of + (Left c, Left (a, _, _)) | componentActor c == a -> pure () + (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure () + _ -> throwE "Author and context aren't the same actor" + case recipient of + Left (GrantRecipProject' j) | j == projectID -> pure () + _ -> throwE "Target 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.GatherAndConvey) $ + throwE "Usage isn't GatherAndConvey" + for_ mdeleg $ \ _ -> + throwE "'delegates' is specified" + return (role', component) + + prepareExtensionGrant component collab role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + uStart <- lift $ getActivityURI authorIdMsig + + (uCollab, audCollab) <- + case collab of + Left personID -> do + personHash <- encodeKeyHashid personID + return + ( encodeRouteHome $ PersonR personHash + , AudLocal [LocalActorPerson personHash] [] + ) + Right raID -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + return (u, AudRemote h [lu] []) + + uComponent <- + case component of + Left c -> do + a <- componentActor <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + enableHash <- encodeKeyHashid enableID + + let audience = [audCollab] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , 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 = uCollab + , AP.grantResult = + Just + (encodeRouteLocal $ + ProjectCollabLiveR projectHash enableHash + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , 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 @@ -1341,6 +1592,7 @@ projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) = AP.AddActivity add -> projectAdd now projectID verse add AP.CreateActivity create -> projectCreate now projectID verse create AP.FollowActivity follow -> projectFollow now projectID verse follow + AP.GrantActivity grant -> projectGrant now projectID verse grant AP.InviteActivity invite -> projectInvite now projectID verse invite AP.JoinActivity join -> projectJoin now projectID verse join AP.RejectActivity reject -> projectReject now projectID verse reject diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 161aa16..e58b68a 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -25,6 +25,7 @@ module Vervis.Data.Collab , parseInvite , parseJoin , parseGrant + , parseGrant' , parseAccept , parseReject , parseRemove @@ -49,6 +50,10 @@ module Vervis.Data.Collab , ComponentBy (..) , hashComponent , componentActor + , resourceToComponent + + , GrantRecipBy' (..) + , hashGrantRecip' ) where @@ -60,6 +65,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.Functor.Identity import Data.Text (Text) +import Data.Traversable import Database.Persist import Database.Persist.Types import GHC.Generics @@ -279,7 +285,8 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = <*> pure mstart <*> pure mend where - parseContext lu = do + parseContext (ObjURI h' lu) = do + unless (h == h') $ throwE "Context and author aren't of same host" hl <- hostIsLocal h if hl then Left <$> do @@ -312,6 +319,66 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = "Grant target contains invalid hashid" else pure $ Right u +parseGrant' + :: AP.Grant URIMode + -> ActE + ( AP.RoleExt + , Either (GrantResourceBy Key) FedURI + , Either (GrantRecipBy' Key) FedURI + , Maybe (LocalURI, Maybe Int) + , Maybe UTCTime + , Maybe UTCTime + , AP.Usage + , Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI) + ) +parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) = + (,,,,,,,) + <$> verifyRole object + <*> parseContext context + <*> parseTarget target + <*> pure + (fmap + (\ (lu, md) -> (lu, (\ (AP.Duration i) -> i) <$> md)) + mresult + ) + <*> pure mstart + <*> pure mend + <*> pure allows + <*> for deleg (fmap (first (\ (actor, _, item) -> (actor, item))) . parseActivityURI') + where + parseContext u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "Grant context isn't a valid route" + resourceHash <- + fromMaybeE + (parseGrantResource route) + "Grant context isn't a shared resource route" + unhashGrantResourceE' + resourceHash + "Grant resource contains invalid hashid" + else pure $ Right u + parseTarget u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "Grant target isn't a valid route" + recipHash <- + fromMaybeE + (parseGrantRecip' route) + "Grant target isn't a grant recipient route" + unhashGrantRecipE' + recipHash + "Grant target contains invalid hashid" + else pure $ Right u + parseAccept (AP.Accept object mresult) = do --verifyNothingE mresult "Accept must not contain 'result'" first (\ (actor, _, item) -> (actor, item)) <$> @@ -503,3 +570,39 @@ unhashComponentE c e = ExceptT $ maybe (Left e) Right <$> unhashComponent c componentActor (ComponentRepo r) = LocalActorRepo r componentActor (ComponentDeck d) = LocalActorDeck d componentActor (ComponentLoom l) = LocalActorLoom l + +resourceToComponent = \case + GrantResourceRepo k -> Just $ ComponentRepo k + GrantResourceDeck k -> Just $ ComponentDeck k + GrantResourceLoom k -> Just $ ComponentLoom k + GrantResourceProject _ -> Nothing + +data GrantRecipBy' f + = GrantRecipPerson' (f Person) + | GrantRecipProject' (f Project) + 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 + +hashGrantRecip' (GrantRecipPerson' k) = + GrantRecipPerson' <$> WAP.encodeKeyHashid k +hashGrantRecip' (GrantRecipProject' k) = + GrantRecipProject' <$> WAP.encodeKeyHashid k + +unhashGrantRecipPure' ctx = f + where + f (GrantRecipPerson' p) = + GrantRecipPerson' <$> decodeKeyHashidPure ctx p + f (GrantRecipProject' p) = + GrantRecipProject' <$> decodeKeyHashidPure ctx p + +unhashGrantRecip' resource = do + ctx <- asksEnv WAP.stageHashidsContext + return $ unhashGrantRecipPure' ctx resource + +unhashGrantRecipE' resource e = + ExceptT $ maybe (Left e) Right <$> unhashGrantRecip' resource diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 853564f..5fadeda 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1868,7 +1868,7 @@ encodeFollow (Follow obj mcontext hide) data Grant u = Grant { grantObject :: RoleExt - , grantContext :: LocalURI + , grantContext :: ObjURI u , grantTarget :: ObjURI u , grantResult :: Maybe (LocalURI, Maybe Duration) , grantStart :: Maybe UTCTime @@ -1881,7 +1881,7 @@ parseGrant :: UriMode u => Authority u -> Object -> Parser (Grant u) parseGrant h o = Grant <$> o .: "object" - <*> withAuthorityO h (o .: "context") + <*> o .: "context" <*> o .: "target" <*> (do mres <- o .:+? "result" for mres $ \case @@ -1897,7 +1897,7 @@ parseGrant h o = encodeGrant :: UriMode u => Authority u -> Grant u -> Series encodeGrant h (Grant obj context target mresult mstart mend allows mdelegates) = "object" .= obj - <> "context" .= ObjURI h context + <> "context" .= context <> "target" .= target <> (case mresult of Nothing -> mempty