S2S: projectAccept: When adding a Collab, delegate access-to-my-components
This commit is contained in:
Pere Lev
parent
fa43a49b16
commit
21aa4e7c49
1 changed files with 133 additions and 7 deletions
|
|
@ -137,6 +137,10 @@ import Vervis.Ticket
|
|||
-- - Component's followers
|
||||
-- - My followers
|
||||
-- - The Accept's sender
|
||||
--
|
||||
-- * In collab mode, if we just sent the collaborator-Grant, also send to
|
||||
-- my new collaborator a delegation-extension Grant for each component I
|
||||
-- have
|
||||
projectAccept
|
||||
:: UTCTime
|
||||
-> ProjectId
|
||||
|
|
@ -311,8 +315,8 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
throwE "This Join already has an Accept"
|
||||
_ -> error "projectAccept impossible"
|
||||
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
lift $ insert_ $ CollabEnable collabID grantID
|
||||
return (collabID, inviterOrJoiner, collab, grantID)
|
||||
enableID <- lift $ insert $ CollabEnable collabID grantID
|
||||
return (collabID, inviterOrJoiner, collab, grantID, enableID)
|
||||
|
||||
-- In Invite-component mode, only if the Accept author is the
|
||||
-- component, record the Accept and enable the Component
|
||||
|
|
@ -361,15 +365,90 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
maybeGrant <-
|
||||
case idsForGrant of
|
||||
|
||||
-- In collab mode, prepare a regular Grant
|
||||
Left (collabID, inviterOrJoiner, collab, grantID) -> lift $ do
|
||||
-- In collab mode, prepare a regular Grant and extension
|
||||
-- Grants
|
||||
Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID) -> lift $ do
|
||||
let isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- do
|
||||
Collab role <- getJust collabID
|
||||
prepareCollabGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return $ Just (grantID, grant)
|
||||
|
||||
recip <-
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueCollabRecipLocal collabID)
|
||||
(getBy $ UniqueCollabRecipRemote collabID)
|
||||
"Found Collab with no recip"
|
||||
"Found Collab with multiple recips"
|
||||
let insertExt =
|
||||
case bimap entityKey entityKey recip of
|
||||
Left localID ->
|
||||
\ enableID furtherID -> insert_ $ ComponentFurtherLocal enableID localID furtherID
|
||||
Right remoteID ->
|
||||
\ enableID furtherID -> insert_ $ ComponentFurtherRemote enableID remoteID furtherID
|
||||
locals <-
|
||||
fmap (map $ over _1 Left) $
|
||||
E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
|
||||
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
|
||||
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
|
||||
E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId
|
||||
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
|
||||
return (deleg E.^. ComponentDelegateLocalGrant, comp, enable)
|
||||
remotes <-
|
||||
fmap (map $ over _1 Right) $
|
||||
E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do
|
||||
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
|
||||
E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
|
||||
E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId
|
||||
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
|
||||
return (deleg E.^. ComponentDelegateRemoteGrant, comp, enable)
|
||||
(uCollab, audCollab) <-
|
||||
case recip of
|
||||
Left (Entity _ (CollabRecipLocal _ personID)) -> do
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
return
|
||||
( encodeRouteHome $ PersonR personHash
|
||||
, AudLocal [LocalActorPerson personHash] []
|
||||
)
|
||||
Right (Entity _ (CollabRecipRemote _ raID)) -> do
|
||||
ra <- getJust raID
|
||||
u@(ObjURI h lu) <- getRemoteActorURI ra
|
||||
return (u, AudRemote h [lu] [])
|
||||
Collab role <- getJust collabID
|
||||
exts <- for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID _) -> do
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insertExt enableID extID
|
||||
componentIdent <- do
|
||||
i <- getComponentIdent componentID
|
||||
bitraverse
|
||||
(pure . snd)
|
||||
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||
i
|
||||
uStart <-
|
||||
case start of
|
||||
Left (E.Value startID) -> do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
c <-
|
||||
case componentIdent of
|
||||
Left ci -> hashComponent ci
|
||||
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
|
||||
s <- encodeKeyHashid startID
|
||||
return $ encodeRouteHome $ activityRoute (componentActor c) s
|
||||
Right (E.Value remoteActivityID) -> do
|
||||
objectID <- remoteActivityIdent <$> getJust remoteActivityID
|
||||
o <- getJust objectID
|
||||
let luAct = remoteObjectIdent o
|
||||
h <- instanceHost <$> getJust (remoteObjectInstance o)
|
||||
return $ ObjURI h luAct
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrant uCollab audCollab componentIdent uStart (min role (componentRole component)) collabEnableID
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
return $ Just (grantID, grant, exts)
|
||||
|
||||
-- In Invite-component mode, only if the Accept author is
|
||||
-- the component, prepare a delegator-Grant
|
||||
|
|
@ -381,7 +460,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
return (grantID, grant, [])
|
||||
|
||||
return (recipActorID, sieve, maybeGrant)
|
||||
|
||||
|
|
@ -390,10 +469,14 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
Just (recipActorID, sieve, maybeGrant) -> do
|
||||
let recipByID = LocalActorProject projectID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), exts) -> do
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
for_ exts $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsExt
|
||||
remoteRecipsExt fwdHostsExt extID actionExt
|
||||
done "Forwarded the Accept and maybe published a Grant"
|
||||
|
||||
where
|
||||
|
|
@ -606,6 +689,49 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
prepareExtensionGrant uCollab audCollab component uStart role enableID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
|
||||
uComponent <-
|
||||
case component of
|
||||
Left c -> do
|
||||
a <- componentActor <$> hashComponent c
|
||||
return $ encodeRouteHome $ renderLocalActor a
|
||||
Right u -> pure u
|
||||
|
||||
enableHash <- encodeKeyHashid enableID
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audCollab]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uStart]
|
||||
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||
{ AP.grantObject = AP.RXRole role
|
||||
, AP.grantContext = uComponent
|
||||
, AP.grantTarget = uCollab
|
||||
, AP.grantResult =
|
||||
Just
|
||||
(encodeRouteLocal $
|
||||
ProjectCollabLiveR projectHash enableHash
|
||||
, Nothing
|
||||
)
|
||||
, AP.grantStart = Just now
|
||||
, AP.grantEnd = Nothing
|
||||
, AP.grantAllows = AP.Invoke
|
||||
, AP.grantDelegates = Just uStart
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
checkExistingComponents
|
||||
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
|
||||
checkExistingComponents projectID componentDB = do
|
||||
|
|
|
|||
Loading…
Reference in a new issue