forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Project: Remove: Implement component-active mode

Browse source
This commit is contained in:
Pere Lev 2024-05-28 00:03:47 +03:00
parent 185047ecb4
commit 44d66c883c
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
2 changed files with 298 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

293
src/Vervis/Actor/Project.hs
View file

@ -4325,6 +4325,20 @@ projectReject = topicReject projectResource LocalResourceProject
-- * Send a Revoke: -- * Send a Revoke:
-- * To: Actor B -- * To: Actor B
-- * CC: Actor A, B's followers, my followers -- * CC: Actor A, B's followers, my followers
--
-- * If C is my components collection:
-- * Verify A is authorized by me
-- * Verify B is an active component of mine
-- * Remove the whole Component record from DB
-- * Forward the Remove to my followers
-- * Send a Revoke on the delegator-Grant:
-- * To: Actor B
-- * CC: Actor A, B's followers, my followers
-- * Send revokes on my extensions of the start-Grant to:
-- * My collaborators
-- * My teams
-- * My parents
--
-- * If C is my children collection: -- * If C is my children collection:
-- * Verify A isn't removing themselves -- * Verify A isn't removing themselves
-- * Verify A is authorized by me to remove actors from me -- * Verify A is authorized by me to remove actors from me
@ -4338,6 +4352,7 @@ projectReject = topicReject projectResource LocalResourceProject
-- delegation Grant I got from B -- delegation Grant I got from B
-- * To: The parent/collaborator/team to whom I'd sent the Grant -- * To: The parent/collaborator/team to whom I'd sent the Grant
-- * CC: - -- * CC: -
--
-- * If C is my parents collection: -- * If C is my parents collection:
-- * Verify A isn't removing themselves -- * Verify A isn't removing themselves
-- * Verify A is authorized by me to remove actors from me -- * Verify A is authorized by me to remove actors from me
@ -4347,9 +4362,11 @@ projectReject = topicReject projectResource LocalResourceProject
-- * Send an Accept on the Remove: -- * Send an Accept on the Remove:
-- * To: Actor B -- * To: Actor B
-- * CC: Actor A, B's followers, my followers -- * CC: Actor A, B's followers, my followers
--
-- * If I'm B, being removed from the parents of a child of mine: -- * If I'm B, being removed from the parents of a child of mine:
-- * Record this Remove in the Source record -- * Record this Remove in the Source record
-- * Forward to followers -- * Forward to followers
--
-- * If I'm B, being removed from the children of a parent of mine: -- * If I'm B, being removed from the children of a parent of mine:
-- * Do nothing, just waiting for parent to send a Revoke on the -- * Do nothing, just waiting for parent to send a Revoke on the
-- delegator-Grant -- delegator-Grant
@ -4366,6 +4383,8 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
case (collection, item) of case (collection, item) of
(Left (Left (LocalResourceProject j)), _) | j == projectID -> (Left (Left (LocalResourceProject j)), _) | j == projectID ->
removeCollab item removeCollab item
(Left (Right (ATProjectComponents j)), _) | j == projectID ->
removeComponentActive item
(Left (Right (ATProjectChildren j)), _) | j == projectID -> (Left (Right (ATProjectChildren j)), _) | j == projectID ->
removeChildActive item removeChildActive item
(Left (Right (ATProjectParents j)), _) | j == projectID -> (Left (Right (ATProjectParents j)), _) | j == projectID ->
@ -4593,6 +4612,280 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
removeComponentActive item = do
-- Check remove
component <-
bitraverse
(\ la ->
fromMaybeE
(resourceToComponent =<< actorToResource la)
"Local component isn't of a component type"
)
pure
item
-- Verify the specified capability gives relevant access
uCap <- do
let muCap = AP.activityCapability $ actbActivity body
fromMaybeE muCap "No capability provided"
verifyCapability''
uCap
authorIdMsig
(LocalResourceProject projectID)
AP.RoleAdmin
maybeNew <- withDBExcept $ do
-- Find member in our DB
componentDB <-
bitraverse
(flip getComponentE "Local removee not found in DB")
(\ u@(ObjURI h lu) -> (,u) <$> do
maybeActor <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance h
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu
MaybeT $ getBy $ UniqueRemoteActor roid
fromMaybeE maybeActor "Remote removee not found in DB"
)
component
-- Grab me from DB
resourceID <- lift $ projectResource <$> getJust projectID
Resource topicActorID <- lift $ getJust resourceID
topicActor <- lift $ getJust topicActorID
-- Find the Component record
existingComponentIDs <-
lift $ case first localComponentID componentDB of
Left komponentID ->
fmap (map $ over _1 Left) $
E.select $ E.from $ \ (comp `E.InnerJoin` local `E.InnerJoin` enable) -> do
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
E.on $ comp E.^. ComponentId E.==. local E.^. ComponentLocalComponent
E.where_ $
comp E.^. ComponentProject E.==. E.val projectID E.&&.
local E.^. ComponentLocalActor E.==. E.val komponentID
return
( local E.^. ComponentLocalId
, comp E.^. ComponentId
, enable
)
Right (Entity remoteActorID _, _) ->
fmap (map $ over _1 Right) $
E.select $ E.from $ \ (comp `E.InnerJoin` remote `E.InnerJoin` enable) -> do
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
E.on $ comp E.^. ComponentId E.==. remote E.^. ComponentRemoteComponent
E.where_ $
comp E.^. ComponentProject E.==. E.val projectID E.&&.
remote E.^. ComponentRemoteActor E.==. E.val remoteActorID
return
( remote E.^. ComponentRemoteId
, comp E.^. ComponentId
, enable
)
(recipID, E.Value componentID, Entity enableID (ComponentEnable _ grantID)) <-
case existingComponentIDs of
[] -> throwE "Remove object isn't a collaborator of me"
[c] -> return c
_ -> error "Multiple enabled Components found for removee"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
usOrThem <-
requireEitherAlt
(getKeyBy $ UniqueComponentOriginInvite componentID)
(getKeyBy $ UniqueComponentOriginAdd componentID)
"Neither us nor them"
"Both us and them"
-- Grab extension-Grants that I'm about to revoke
furthersL <- selectList [ComponentFurtherLocalComponent ==. enableID] []
furthersR <- selectList [ComponentFurtherRemoteComponent ==. enableID] []
gathers <- selectList [ComponentGatherComponent ==. enableID] []
conveys <- selectList [ComponentConveyComponent ==. enableID] []
-- Delete the whole Component record
deleteWhere [ComponentFurtherLocalComponent ==. enableID]
deleteWhere [ComponentFurtherRemoteComponent ==. enableID]
deleteWhere [ComponentGatherComponent ==. enableID]
deleteWhere [ComponentConveyComponent ==. enableID]
case recipID of
Left (E.Value localID) -> deleteBy $ UniqueComponentDelegateLocal localID
Right (E.Value remoteID) -> deleteBy $ UniqueComponentDelegateRemote remoteID
delete enableID
case usOrThem of
Left usID -> do
deleteBy $ UniqueComponentProjectAccept usID
delete usID
Right themID -> do
deleteBy $ UniqueComponentGestureLocal themID
deleteBy $ UniqueComponentGestureRemote themID
delete themID
deleteBy $ UniqueComponentProjectGestureLocal componentID
deleteBy $ UniqueComponentProjectGestureRemote componentID
case recipID of
Left (E.Value localID) -> do
deleteBy $ UniqueComponentAcceptLocal localID
delete localID
Right (E.Value remoteID) -> do
deleteBy $ UniqueComponentAcceptRemote remoteID
delete remoteID
delete componentID
-- Prepare forwarding Remove to my followers
sieve <- lift $ do
topicHash <- encodeKeyHashid projectID
let topicByHash =
LocalActorProject topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Prepare main Revoke activity and insert to my outbox
revoke@(actionRevoke, _, _, _) <-
lift $ prepareMainRevoke componentDB grantID
let recipByKey = LocalActorProject projectID
revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
-- Prepare and insert Revokes on all the extension-Grants
revokesG <- for gathers $ \ (Entity _ (ComponentGather _ startID grantID)) -> do
DestUsStart acceptID _ <- getJust startID
DestUsAccept destID _ <- getJust acceptID
parent <- do
p <- getDestTopic destID
bitraverse
(\case
Left j -> pure $ LocalActorProject j
Right _ -> error "I'm a project but I have a parent who is a Group"
)
pure
(bimap snd snd p)
return (parent, grantID)
revokesFL <- for furthersL $ \ (Entity _ (ComponentFurtherLocal _ delegID grantID)) -> do
CollabDelegLocal _ recipLocalID _ <- getJust delegID
CollabRecipLocal _ personID <- getJust recipLocalID
return
( Left $ LocalActorPerson personID
, grantID
)
revokesFR <- for furthersR $ \ (Entity _ (ComponentFurtherRemote _ delegID grantID)) -> do
CollabDelegRemote _ recipRemoteID _ <- getJust delegID
CollabRecipRemote _ actorID <- getJust recipRemoteID
return
( Right actorID
, grantID
)
revokesC <- for conveys $ \ (Entity _ (ComponentConvey _ startID grantID)) -> do
SquadUsStart acceptID _ <- getJust startID
SquadUsAccept squadID _ <- getJust acceptID
team <- bimap (LocalActorGroup . snd) snd <$> getSquadTeam squadID
return (team, grantID)
revokes <- for (revokesG ++ revokesFL ++ revokesFR ++ revokesC) $ \ (actor, grantID) -> do
ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID
let recipByKey = LocalActorProject projectID
extID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
_luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext)
return (topicActorID, 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 = LocalActorProject projectID
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 "[Component-active] Deleted the Component, forwarded Remove, sent Revokes"
where
prepareMainRevoke component grantID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
recipHash <- encodeKeyHashid projectID
let topicByHash = LocalActorProject recipHash
componentHash <- bitraverse (hashComponent . bmap entityKey) pure component
audRemover <- makeAudSenderOnly authorIdMsig
let audChild =
case componentHash of
Left c ->
let a = resourceToActor $ componentResource c
in AudLocal [a] [localActorFollowers a]
Right (Entity _ actor, ObjURI h lu) ->
AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
audMe = AudLocal [] [localActorFollowers topicByHash]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audRemover, audChild, 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
projectHash <- encodeKeyHashid projectID
let topicByHash = LocalActorProject projectHash
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)
removeChildActive child = do removeChildActive child = do
-- If child is local, find it in our DB -- If child is local, find it in our DB

10
th/models
View file

@ -1026,8 +1026,8 @@ ComponentEnable
UniqueComponentEnable component UniqueComponentEnable component
UniqueComponentEnableGrant grant UniqueComponentEnableGrant grant
-- Witnesses that the component used the delegator Grant to send an admin -- Witnesses that the component used the delegator Grant to send a start-Grant
-- delegation to the project, to extend the delegation further -- to the project, to extend further
ComponentDelegateLocal ComponentDelegateLocal
component ComponentLocalId component ComponentLocalId
@ -1043,7 +1043,7 @@ ComponentDelegateRemote
UniqueComponentDelegateRemote component UniqueComponentDelegateRemote component
UniqueComponentDelegateRemoteGrant grant UniqueComponentDelegateRemoteGrant grant
-- Witnesses that the project has extended a given delegation to a given -- Witnesses that the project has extended the start-Grant to a given
-- direct collaborator -- direct collaborator
ComponentFurtherLocal ComponentFurtherLocal
@ -1062,7 +1062,7 @@ ComponentFurtherRemote
UniqueComponentFurtherRemote component collab UniqueComponentFurtherRemote component collab
UniqueComponentFurtherRemoteGrant grant UniqueComponentFurtherRemoteGrant grant
-- Witnesses that the project has extended a given delegation to a given -- Witnesses that the project has extended the start-Grant to a given
-- parent -- parent
ComponentGather ComponentGather
@ -1073,7 +1073,7 @@ ComponentGather
UniqueComponentGather component parent UniqueComponentGather component parent
UniqueComponentGatherGrant grant UniqueComponentGatherGrant grant
-- Witnesses that the project has extended the delegation to a given team -- Witnesses that the project has extended the start-Grant to a given team
ComponentConvey ComponentConvey
component ComponentEnableId component ComponentEnableId