diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 410c713..b4041dd 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -705,9 +705,17 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor -- Check invite (role, targetByKey) <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (role, resource, recipient) <- parseInvite author invite - unless (Left (topicResource topicKey) == resource) $ + (role, resourceOrComps, recipientOrComp) <- parseInvite author invite + unless (Left (Left $ topicResource topicKey) == resourceOrComps) $ throwE "Invite topic isn't my collabs URI" + recipient <- + bitraverse + (\case + Left r -> pure r + Right _ -> throwE "Not accepting component actors as collabs" + ) + pure + recipientOrComp return (role, recipient) -- If target is local, find it in our DB diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 7fceec9..37e0151 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -451,7 +451,7 @@ personInvite personInvite now recipPersonID (Verse authorIdMsig body) invite = do -- Check input - recipient <- do + recipientOrComp <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig (_role, _resource, target) <- parseInvite author invite return target @@ -471,8 +471,8 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do Nothing -> done "I already have this activity in my inbox" Just actorID -> do let targetIsRecip = - case recipient of - Left (GrantRecipPerson p) -> p == recipPersonID + case recipientOrComp of + Left (Left (GrantRecipPerson p)) -> p == recipPersonID _ -> False if not targetIsRecip then done "I'm not the target; Inserted to inbox" diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 17c4f51..ffa905a 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -478,7 +478,23 @@ clientInvite clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do -- Check input - (_role, resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite + (_role, resourceOrComps, recipientOrComp) <- parseInvite (Left $ LocalActorPerson personMeID) invite + resource <- + bitraverse + (\case + Left r -> pure r + Right _ -> throwE "Not accepting project components as target" + ) + pure + resourceOrComps + recipient <- + bitraverse + (\case + Left r -> pure r + Right _ -> throwE "Not accepting component actors as collabs" + ) + pure + recipientOrComp _capID <- fromMaybeE maybeCap "No capability provided" -- If resource collabs URI is remote, HTTP GET it and its resource and its diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 1cee9a7..14aaa5c 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -983,8 +983,24 @@ invite personID uRecipient uResourceCollabs role = do env <- asksSite appEnv let activity = AP.Invite role uRecipient uResourceCollabs - (_role, resource, recipient) <- + (_role, resourceOrComps, recipientOrComp) <- runActE $ parseInvite (Left $ LocalActorPerson personID) activity + resource <- + bitraverse + (\case + Left r -> pure r + Right _-> throwE "Not accepting project components as target" + ) + pure + resourceOrComps + recipient <- + bitraverse + (\case + Left r -> pure r + Right _ -> throwE "Not accepting component actors as collabs" + ) + pure + recipientOrComp -- If resource collabs is remote, we need to get it from DB/HTTP to -- determine the resourc & its managing actor & followers collection diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index d61e63f..4600780 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -51,6 +51,7 @@ module Vervis.Data.Collab ) where +import Control.Applicative import Control.Monad import Control.Monad.Trans.Except import Data.Barbie @@ -148,6 +149,28 @@ parseTopic u = do pure routeOrRemote +parseTopic' + :: StageRoute Env ~ Route App + => FedURI + -> ActE (Either (Either (GrantResourceBy Key) ProjectId) FedURI) +parseTopic' u = do + routeOrRemote <- parseFedURI u + bitraverse + (\case + ProjectComponentsR j -> + Right <$> WAP.decodeKeyHashidE j "Not a project components route" + route -> Left <$> do + resourceHash <- + fromMaybeE + (parseGrantResourceCollabs route) + "Not a shared resource collabs route" + unhashGrantResourceE' + resourceHash + "Contains invalid hashid" + ) + pure + routeOrRemote + parseRecipient sender u = do routeOrRemote <- parseFedURI u bitraverse @@ -172,20 +195,55 @@ parseRecipient sender u = do ) routeOrRemote +parseRecipient' sender u = do + routeOrRemote <- parseFedURI u + bitraverse + (\ route -> do + recipOrComp <- + Left <$> + fromMaybeE + (parseGrantRecip route) + "Not a grant recipient route" + <|> + Right <$> + fromMaybeE + (parseComponent route) + "Not a component route" + bitraverse + (\ recipHash -> do + recipKey <- + unhashGrantRecipE + recipHash + "Contains invalid hashid" + case recipKey of + GrantRecipPerson p | Left (LocalActorPerson p) == sender -> + throwE "Invite local sender and recipient are the same Person" + _ -> return recipKey + ) + (flip unhashComponentE "Contains invalid keyhashid") + recipOrComp + ) + (\ u -> do + when (Right u == sender) $ + throwE "Invite remote sender and recipient are the same actor" + return u + ) + routeOrRemote + parseInvite :: StageRoute Env ~ Route App => Either (LocalActorBy Key) FedURI -> AP.Invite URIMode -> ActE ( AP.Role - , Either (GrantResourceBy Key) FedURI - , Either (GrantRecipBy Key) FedURI + , Either (Either (GrantResourceBy Key) ProjectId) FedURI + , Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI ) parseInvite sender (AP.Invite instrument object target) = (,,) <$> verifyRole instrument - <*> nameExceptT "Invite target" (parseTopic target) - <*> nameExceptT "Invite object" (parseRecipient sender object) + <*> nameExceptT "Invite target" (parseTopic' target) + <*> nameExceptT "Invite object" (parseRecipient' sender object) parseJoin :: StageRoute Env ~ Route App @@ -318,11 +376,6 @@ parseAdd sender (AP.Add object target role) = do ) pure routeOrRemote - where - parseComponent (RepoR r) = Just $ ComponentRepo r - parseComponent (DeckR d) = Just $ ComponentDeck d - parseComponent (LoomR l) = Just $ ComponentLoom l - parseComponent _ = Nothing parseProjectComps u = do routeOrRemote <- parseFedURI u bitraverse @@ -427,6 +480,11 @@ data ComponentBy f deriving instance AllBF Eq f ComponentBy => Eq (ComponentBy f) +parseComponent (RepoR r) = Just $ ComponentRepo r +parseComponent (DeckR d) = Just $ ComponentDeck d +parseComponent (LoomR l) = Just $ ComponentLoom l +parseComponent _ = Nothing + unhashComponentPure ctx = f where f (ComponentRepo r) =