S2S: Group: Remove: Implement resource-active mode
This commit is contained in:
Pere Lev
parent
a36eda1e2b
commit
9df437a043
1 changed files with 294 additions and 0 deletions
|
|
@ -3956,6 +3956,18 @@ groupReject = topicReject groupResource LocalResourceGroup
|
|||
-- * Send an Accept on the Remove:
|
||||
-- * To: Actor B
|
||||
-- * CC: Actor A, B's followers, my followers
|
||||
-- * If C is my resources collection:
|
||||
-- * Verify A is authorized by me to remove resources from me
|
||||
-- * Verify B is an active resource of mine
|
||||
-- * Remove the whole Effort record from DB
|
||||
-- * Forward the Remove to my followers
|
||||
-- * Send a Revoke on the delegator-Grant I had for B:
|
||||
-- * To: Actor B
|
||||
-- * CC: Actor A, B's followers, my followers
|
||||
-- * Send a Revoke on every extention-Grant I extended on every
|
||||
-- delegation Grant I got from B
|
||||
-- * To: The child/member to whom I'd sent the Grant
|
||||
-- * CC: -
|
||||
-- * If I'm B, being removed from the children of a parent of mine:
|
||||
-- * Record this Remove in the Source record
|
||||
-- * Forward to followers
|
||||
|
|
@ -3979,6 +3991,8 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do
|
|||
removeChildActive item
|
||||
(Left (Right (ATGroupParents j)), _) | j == groupID ->
|
||||
removeParentActive item
|
||||
(Left (Right (ATGroupEfforts j)), _) | j == groupID ->
|
||||
removeResourceActive item
|
||||
(_, Left (LocalActorGroup j)) | j == groupID ->
|
||||
case collection of
|
||||
Left (Right (ATGroupParents j)) | j /= groupID ->
|
||||
|
|
@ -4872,6 +4886,286 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do
|
|||
Just inboxItemID ->
|
||||
doneDB inboxItemID "[Child-passive] Saw the removal attempt, just waiting for the Revoke"
|
||||
|
||||
removeResourceActive resource = do
|
||||
|
||||
-- If resource is local, find it in our DB
|
||||
-- If resource is remote, HTTP GET it, verify it's an actor of Group
|
||||
-- type, and store in our DB (if it's already there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result would be sent later in a separate (e.g. Accept) activity.
|
||||
-- But for the PoC level, the current situation will hopefully do.
|
||||
resourceDB <-
|
||||
bitraverse
|
||||
(\ la ->
|
||||
case resourceToNG =<< actorToResource la of
|
||||
Just ng -> withDBExcept $ getLocalResourceEntityE (resourceFromNG ng) "Resource not found in DB"
|
||||
Nothing -> throwE "Local resource of non-resource type"
|
||||
)
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h lu
|
||||
case result of
|
||||
Left Nothing -> throwE "Resource @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Resource isn't an actor"
|
||||
Right (Just actor) -> do
|
||||
case remoteActorType $ entityVal actor of
|
||||
AP.ActorTypeTeam -> pure ()
|
||||
_ -> throwE "Remote resource type isn't Group"
|
||||
return (u, actor)
|
||||
)
|
||||
resource
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the sender is authorized by me to remove a resource
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalResourceGroup groupID)
|
||||
AP.RoleAdmin
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(group, actorRecip) <- lift $ do
|
||||
p <- getJust groupID
|
||||
(p,) <$> getJust (groupActor p)
|
||||
|
||||
-- Verify it's an active resource of mine
|
||||
efforts <- lift $ case resourceDB of
|
||||
Left r ->
|
||||
fmap (map $ \ (s, d, E.Value a, E.Value t) -> (s, d, Left (a, t))) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
|
||||
E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
|
||||
E.on $ topic E.^. EffortTopicLocalId E.==. accept E.^. EffortThemAcceptLocalTopic
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort
|
||||
E.where_ $
|
||||
effort E.^. EffortHolder E.==. E.val groupID E.&&.
|
||||
topic E.^. EffortTopicLocalTopic E.==. E.val (localResourceID r)
|
||||
return
|
||||
( effort E.^. EffortId
|
||||
, send
|
||||
, accept E.^. EffortThemAcceptLocalId
|
||||
, topic E.^. EffortTopicLocalId
|
||||
)
|
||||
Right (_, Entity a _) ->
|
||||
fmap (map $ \ (s, d, E.Value a, E.Value t) -> (s, d, Right (a, t))) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
|
||||
E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
|
||||
E.on $ topic E.^. EffortTopicRemoteId E.==. accept E.^. EffortThemAcceptRemoteTopic
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort
|
||||
E.where_ $
|
||||
effort E.^. EffortHolder E.==. E.val groupID E.&&.
|
||||
topic E.^. EffortTopicRemoteTopic E.==. E.val a
|
||||
return
|
||||
( effort E.^. EffortId
|
||||
, send
|
||||
, accept E.^. EffortThemAcceptRemoteId
|
||||
, topic E.^. EffortTopicRemoteId
|
||||
)
|
||||
(E.Value effortID, Entity sendID (EffortUsSendDelegator _ grantID), topic) <-
|
||||
verifySingleE efforts "No effort" "Multiple efforts"
|
||||
|
||||
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
|
||||
|
||||
-- Grab extension-Grants that I'm about to revoke
|
||||
distributes <- selectList [EffortUsDistributeEffort ==. sendID] []
|
||||
leafs <- selectList [EffortUsLeafEffort ==. sendID] []
|
||||
|
||||
-- Delete the whole Effort record
|
||||
deleteWhere [EffortRemoveSend ==. sendID]
|
||||
let distributeIDs = map entityKey distributes
|
||||
deleteWhere [EffortUsDistributeFromLocalDistribute <-. distributeIDs]
|
||||
deleteWhere [EffortUsDistributeFromRemoteDistribute <-. distributeIDs]
|
||||
deleteWhere [EffortUsDistributeId <-. distributeIDs]
|
||||
let leafIDs = map entityKey leafs
|
||||
deleteWhere [EffortUsLeafFromLocalLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafFromRemoteLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafToLocalLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafToRemoteLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafId <-. leafIDs]
|
||||
case topic of
|
||||
Left (localID, _) -> do
|
||||
deleteWhere [EffortThemDelegateLocalEffort ==. localID]
|
||||
delete localID
|
||||
Right (remoteID, _) -> do
|
||||
deleteWhere [EffortThemDelegateRemoteEffort ==. remoteID]
|
||||
delete remoteID
|
||||
delete sendID
|
||||
origin <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniqueEffortOriginUs effortID)
|
||||
(getKeyBy $ UniqueEffortOriginThem effortID)
|
||||
"Neither us nor them"
|
||||
"Both us and them"
|
||||
case origin of
|
||||
Left usID -> do
|
||||
deleteBy $ UniqueEffortUsAccept usID
|
||||
deleteBy $ UniqueEffortUsGestureLocal usID
|
||||
deleteBy $ UniqueEffortUsGestureRemote usID
|
||||
delete usID
|
||||
Right themID -> do
|
||||
deleteBy $ UniqueEffortThemGestureLocal themID
|
||||
deleteBy $ UniqueEffortThemGestureRemote themID
|
||||
delete themID
|
||||
case topic of
|
||||
Left (_, l) -> delete l
|
||||
Right (_, r) -> delete r
|
||||
delete effortID
|
||||
|
||||
-- Prepare forwarding Remove to my followers
|
||||
sieve <- lift $ do
|
||||
topicHash <- encodeKeyHashid groupID
|
||||
let topicByHash =
|
||||
LocalActorGroup topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
|
||||
-- Prepare main Revoke activity and insert to my outbox
|
||||
revoke@(actionRevoke, _, _, _) <-
|
||||
lift $ prepareMainRevoke resourceDB grantID
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
|
||||
|
||||
-- Prepare and insert Revokes on all the extension-Grants
|
||||
revokesD <- for distributes $ \ (Entity _ (EffortUsDistribute _ startID grantID)) -> do
|
||||
DestUsStart acceptID _ <- getJust startID
|
||||
DestUsAccept destID _ <- getJust acceptID
|
||||
child <- do
|
||||
c <- getDestTopic destID
|
||||
bitraverse
|
||||
(\case
|
||||
Right j -> pure $ LocalActorGroup j
|
||||
Left _ -> error "I'm a group but I have a child who is a Project"
|
||||
)
|
||||
pure
|
||||
(bimap snd snd c)
|
||||
return (child, grantID)
|
||||
revokesL <- for leafs $ \ (Entity _ (EffortUsLeaf _ enableID grantID)) -> do
|
||||
CollabEnable collabID _ <- getJust enableID
|
||||
recip <- getCollabRecip collabID
|
||||
return
|
||||
( bimap
|
||||
(LocalActorPerson . collabRecipLocalPerson . entityVal)
|
||||
(collabRecipRemoteActor . entityVal)
|
||||
recip
|
||||
, grantID
|
||||
)
|
||||
revokes <- for (revokesD ++ revokesL) $ \ (actor, grantID) -> do
|
||||
ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
return (groupActor group, sieve, revokeID, revoke, revokes, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), revokes, inboxItemID) -> do
|
||||
let topicByID = LocalActorGroup groupID
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
lift $ do
|
||||
sendActivity
|
||||
topicByID topicActorID localRecipsRevoke
|
||||
remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
|
||||
for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
|
||||
sendActivity
|
||||
topicByID topicActorID localRecipsExt
|
||||
remoteRecipsExt fwdHostsExt extID actionExt
|
||||
doneDB inboxItemID "[Resource-active] Deleted the Effort, forwarded Remove, sent Revokes"
|
||||
|
||||
where
|
||||
|
||||
prepareMainRevoke resource grantID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
recipHash <- encodeKeyHashid groupID
|
||||
let topicByHash = LocalActorGroup recipHash
|
||||
|
||||
resourceHash <- bitraverse (hashLocalResource . bmap entityKey) pure resource
|
||||
|
||||
audRemover <- makeAudSenderOnly authorIdMsig
|
||||
let audResource =
|
||||
case resourceHash of
|
||||
Left lr ->
|
||||
let la = resourceToActor lr
|
||||
in AudLocal [la] [localActorFollowers la]
|
||||
Right (ObjURI h lu, Entity _ actor) ->
|
||||
AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
|
||||
audMe = AudLocal [] [localActorFollowers topicByHash]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audRemover, audResource, audMe]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
||||
uRemove <- getActivityURI authorIdMsig
|
||||
luGrant <- do
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
return $ encodeRouteLocal $ activityRoute topicByHash grantHash
|
||||
let action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uRemove]
|
||||
, AP.actionSpecific = AP.RevokeActivity AP.Revoke
|
||||
{ AP.revokeObject = luGrant :| []
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
prepareExtRevoke recipient grantID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
groupHash <- encodeKeyHashid groupID
|
||||
let topicByHash = LocalActorGroup groupHash
|
||||
|
||||
audRecip <-
|
||||
case recipient of
|
||||
Left a -> do
|
||||
h <- hashLocalActor a
|
||||
return $ AudLocal [h] [localActorFollowers h]
|
||||
Right actorID -> do
|
||||
actor <- getJust actorID
|
||||
ObjURI h lu <- getRemoteActorURI actor
|
||||
return $
|
||||
AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audRecip]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
||||
uRemove <- lift $ getActivityURI authorIdMsig
|
||||
luGrant <- do
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
return $ encodeRouteLocal $ activityRoute topicByHash grantHash
|
||||
let action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uRemove]
|
||||
, AP.actionSpecific = AP.RevokeActivity AP.Revoke
|
||||
{ AP.revokeObject = luGrant :| []
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor is revoking Grant activities
|
||||
-- Behavior:
|
||||
-- * For each revoked activity:
|
||||
|
|
|
|||
Loading…
Reference in a new issue