diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 287a824..95cf606 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -75,7 +75,7 @@ import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Persist.Follow -import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localRecipSieve) +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localRecipSieve, localActorFollowers) import Vervis.RemoteActorStore import Vervis.Ticket @@ -97,6 +97,14 @@ verifyResourceAddressed localRecips resource = do routes <- lookup r $ recipProjects localRecips guard $ routeProject routes +verifyProjectAddressed localRecips projectID = do + projectHash <- encodeKeyHashid projectID + fromMaybeE (verify projectHash) "Project not addressed" + where + verify j = do + routes <- lookup j $ recipProjects localRecips + guard $ routeProject routes + verifyRecipientAddressed localRecips recipient = do recipientHash <- hashGrantRecip recipient fromMaybeE (verify recipientHash) "Recipient not addressed" @@ -105,6 +113,21 @@ verifyRecipientAddressed localRecips recipient = do routes <- lookup p $ recipPeople localRecips guard $ routePerson routes +verifyComponentAddressed :: RecipientRoutes -> ComponentBy Key -> ActE () +verifyComponentAddressed localRecips component = do + componentHash <- hashComponent component + fromMaybeE (verify componentHash) "Local component not addressed" + where + verify (ComponentRepo r) = do + routes <- lookup r $ recipRepos localRecips + guard $ routeRepo routes + verify (ComponentDeck d) = do + routes <- lookup d $ recipDecks localRecips + guard $ routeDeck $ familyDeck routes + verify (ComponentLoom l) = do + routes <- lookup l $ recipLooms localRecips + guard $ routeLoom $ familyLoom routes + verifyRemoteAddressed :: [(Host, NonEmpty LocalURI)] -> FedURI -> ActE () verifyRemoteAddressed remoteRecips u = fromMaybeE (verify u) "Given remote entity not addressed" @@ -478,23 +501,7 @@ clientInvite clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do -- Check input - (_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 + (_role, resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite _capID <- fromMaybeE maybeCap "No capability provided" -- If resource collabs URI is remote, HTTP GET it and its resource and its @@ -502,14 +509,17 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- our DB. resourceDB <- bitraverse - (withDBExcept . flip getGrantResource "Grant context not found in DB") + (bitraverse + (withDBExcept . flip getGrantResource "Grant resource not found in DB") + (withDBExcept . flip getEntityE "Grant context project not found in DB") + ) (\ u@(ObjURI h luColl) -> do manager <- asksEnv envHttpManager coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" - AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu - unless (mluCollabs == Just luColl) $ - throwE "Invite target isn't a collabs list" + AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + unless (mluCollabs == Just luColl || mluComps == Just luColl) $ + throwE "Invite target isn't a collabs/components list" instanceID <- lift $ withDB $ either entityKey id <$> insertBy' (Instance h) @@ -528,7 +538,10 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- it to our DB. If recipient is local, find it in our DB. recipientDB <- bitraverse - (withDBExcept . flip getGrantRecip "Grant recipient not found in DB") + (bitraverse + (withDBExcept . flip getGrantRecip "Grant recipient person not found in DB") + (withDBExcept . flip getComponentE "Grant recipient component not found in DB") + ) (\ u@(ObjURI h lu) -> do instanceID <- lift $ withDB $ either entityKey id <$> insertBy' (Instance h) @@ -545,11 +558,17 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- Verify that resource and recipient are addressed by the Invite bitraverse_ - (verifyResourceAddressed localRecips . bmap entityKey) + (bitraverse_ + (verifyResourceAddressed localRecips . bmap entityKey) + (verifyProjectAddressed localRecips . entityKey) + ) (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) resourceDB bitraverse_ - (verifyRecipientAddressed localRecips . bmap entityKey) + (bitraverse_ + (verifyRecipientAddressed localRecips . bmap entityKey) + (verifyComponentAddressed localRecips . bmap entityKey) + ) (verifyRemoteAddressed remoteRecips . snd) recipientDB @@ -566,31 +585,29 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- Prepare local recipients for Invite delivery sieve <- lift $ do - resourceHash <- bitraverse hashGrantResource' pure resource - recipientHash <- bitraverse hashGrantRecip pure recipient + resourceHash <- bitraverse (bitraverse hashGrantResource' encodeKeyHashid) pure resource + recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient senderHash <- encodeKeyHashid personMeID let sieveActors = catMaybes [ case resourceHash of - Left (GrantResourceRepo r) -> Just $ LocalActorRepo r - Left (GrantResourceDeck d) -> Just $ LocalActorDeck d - Left (GrantResourceLoom l) -> Just $ LocalActorLoom l - Left (GrantResourceProject l) -> Just $ LocalActorProject l - Right _ -> Nothing + Left (Left r) -> Just $ grantResourceLocalActor r + Left (Right j) -> Just $ LocalActorProject j + Right _ -> Nothing , case recipientHash of - Left (GrantRecipPerson p) -> Just $ LocalActorPerson p - Right _ -> Nothing + Left (Left (GrantRecipPerson p)) -> Just $ LocalActorPerson p + Left (Right c) -> Just $ componentActor c + Right _ -> Nothing ] sieveStages = catMaybes [ Just $ LocalStagePersonFollowers senderHash , case resourceHash of - Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r - Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d - Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l - Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l - Right _ -> Nothing + Left (Left r) -> Just $ localActorFollowers $ grantResourceLocalActor r + Left (Right j) -> Just $ LocalStageProjectFollowers j + Right _ -> Nothing , case recipientHash of - Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p - Right _ -> Nothing + Left (Left (GrantRecipPerson p)) -> Just $ LocalStagePersonFollowers p + Left (Right c) -> Just $ localActorFollowers $ componentActor c + Right _ -> Nothing ] return $ makeRecipientSet sieveActors sieveStages return