sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-29 00:44:52 +09:00
Code Issues 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.Collab
import Vervis.Persist.Discussion import Vervis.Persist.Discussion
import Vervis.Persist.Follow 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.RemoteActorStore
import Vervis.Ticket import Vervis.Ticket
@ -97,6 +97,14 @@ verifyResourceAddressed localRecips resource = do
routes <- lookup r $ recipProjects localRecips routes <- lookup r $ recipProjects localRecips
guard $ routeProject routes 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 verifyRecipientAddressed localRecips recipient = do
recipientHash <- hashGrantRecip recipient recipientHash <- hashGrantRecip recipient
fromMaybeE (verify recipientHash) "Recipient not addressed" fromMaybeE (verify recipientHash) "Recipient not addressed"
@ -105,6 +113,21 @@ verifyRecipientAddressed localRecips recipient = do
routes <- lookup p $ recipPeople localRecips routes <- lookup p $ recipPeople localRecips
guard $ routePerson routes 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 :: [(Host, NonEmpty LocalURI)] -> FedURI -> ActE ()
verifyRemoteAddressed remoteRecips u = verifyRemoteAddressed remoteRecips u =
fromMaybeE (verify u) "Given remote entity not addressed" fromMaybeE (verify u) "Given remote entity not addressed"
@ -478,23 +501,7 @@ clientInvite
clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do
-- Check input -- Check input
(_role, resourceOrComps, recipientOrComp) <- parseInvite (Left $ LocalActorPerson personMeID) invite (_role, resource, recipient) <- 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" _capID <- fromMaybeE maybeCap "No capability provided"
-- If resource collabs URI is remote, HTTP GET it and its resource and its -- 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. -- our DB.
resourceDB <- resourceDB <-
bitraverse 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 (\ u@(ObjURI h luColl) -> do
manager <- asksEnv envHttpManager manager <- asksEnv envHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl 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'" 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 AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
unless (mluCollabs == Just luColl) $ unless (mluCollabs == Just luColl || mluComps == Just luColl) $
throwE "Invite target isn't a collabs list" throwE "Invite target isn't a collabs/components list"
instanceID <- instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h) 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. -- it to our DB. If recipient is local, find it in our DB.
recipientDB <- recipientDB <-
bitraverse 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 (\ u@(ObjURI h lu) -> do
instanceID <- instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h) 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 -- Verify that resource and recipient are addressed by the Invite
bitraverse_ bitraverse_
(verifyResourceAddressed localRecips . bmap entityKey) (bitraverse_
(verifyResourceAddressed localRecips . bmap entityKey)
(verifyProjectAddressed localRecips . entityKey)
)
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
resourceDB resourceDB
bitraverse_ bitraverse_
(verifyRecipientAddressed localRecips . bmap entityKey) (bitraverse_
(verifyRecipientAddressed localRecips . bmap entityKey)
(verifyComponentAddressed localRecips . bmap entityKey)
)
(verifyRemoteAddressed remoteRecips . snd) (verifyRemoteAddressed remoteRecips . snd)
recipientDB recipientDB
@ -566,31 +585,29 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Prepare local recipients for Invite delivery -- Prepare local recipients for Invite delivery
sieve <- lift $ do sieve <- lift $ do
resourceHash <- bitraverse hashGrantResource' pure resource resourceHash <- bitraverse (bitraverse hashGrantResource' encodeKeyHashid) pure resource
recipientHash <- bitraverse hashGrantRecip pure recipient recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient
senderHash <- encodeKeyHashid personMeID senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes let sieveActors = catMaybes
[ case resourceHash of [ case resourceHash of
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r Left (Left r) -> Just $ grantResourceLocalActor r
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d Left (Right j) -> Just $ LocalActorProject j
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l Right _ -> Nothing
Left (GrantResourceProject l) -> Just $ LocalActorProject l
Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p Left (Left (GrantRecipPerson p)) -> Just $ LocalActorPerson p
Right _ -> Nothing Left (Right c) -> Just $ componentActor c
Right _ -> Nothing
] ]
sieveStages = catMaybes sieveStages = catMaybes
[ Just $ LocalStagePersonFollowers senderHash [ Just $ LocalStagePersonFollowers senderHash
, case resourceHash of , case resourceHash of
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r Left (Left r) -> Just $ localActorFollowers $ grantResourceLocalActor r
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d Left (Right j) -> Just $ LocalStageProjectFollowers j
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l Right _ -> Nothing
Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p Left (Left (GrantRecipPerson p)) -> Just $ LocalStagePersonFollowers p
Right _ -> Nothing Left (Right c) -> Just $ localActorFollowers $ componentActor c
Right _ -> Nothing
] ]
return $ makeRecipientSet sieveActors sieveStages return $ makeRecipientSet sieveActors sieveStages
return return