forge/Vervis
1
0
Fork 0
Code Pull requests Activity

C2S: Invite: Support component mode

Browse source
This commit is contained in:
Pere Lev 2023-10-23 18:26:44 +03:00
parent 21aa4e7c49
commit 477793688f
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
1 changed files with 58 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

99
src/Vervis/Actor/Person/Client.hs
View file

@ -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