C2S: Invite: Support component mode
This commit is contained in:
Pere Lev
parent
21aa4e7c49
commit
477793688f
1 changed files with 58 additions and 41 deletions
|
|
@ -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_
|
||||
(bitraverse_
|
||||
(verifyResourceAddressed localRecips . bmap entityKey)
|
||||
(verifyProjectAddressed localRecips . entityKey)
|
||||
)
|
||||
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
|
||||
resourceDB
|
||||
bitraverse_
|
||||
(bitraverse_
|
||||
(verifyRecipientAddressed localRecips . bmap entityKey)
|
||||
(verifyComponentAddressed localRecips . bmap entityKey)
|
||||
)
|
||||
(verifyRemoteAddressed remoteRecips . snd)
|
||||
recipientDB
|
||||
|
||||
|
|
@ -566,30 +585,28 @@ 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
|
||||
Left (Left r) -> Just $ grantResourceLocalActor r
|
||||
Left (Right j) -> Just $ LocalActorProject j
|
||||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
|
||||
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
|
||||
Left (Left r) -> Just $ localActorFollowers $ grantResourceLocalActor r
|
||||
Left (Right j) -> Just $ LocalStageProjectFollowers j
|
||||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
|
||||
Left (Left (GrantRecipPerson p)) -> Just $ LocalStagePersonFollowers p
|
||||
Left (Right c) -> Just $ localActorFollowers $ componentActor c
|
||||
Right _ -> Nothing
|
||||
]
|
||||
return $ makeRecipientSet sieveActors sieveStages
|
||||
|
|
|
|||
Loading…
Reference in a new issue