S2S: Group: Accept: Implement remove-resource mode
This commit is contained in:
Pere Lev
parent
cd18217f08
commit
c385dad10b
1 changed files with 244 additions and 2 deletions
|
|
@ -979,6 +979,19 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
|
|||
-- - Resource's followers
|
||||
-- - My followers
|
||||
-- - The Accept sender (my collaborator)
|
||||
--
|
||||
-- * Remove-Resource-Passive mode:
|
||||
-- * Verify the Effort is enabled
|
||||
-- * Verify the sender is the resource
|
||||
-- * Delete the entire Effort record
|
||||
-- * Forward the Accept 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: -
|
||||
groupAccept
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
|
|
@ -1015,7 +1028,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|>
|
||||
runExceptT (Right . Right <$> tryRemoveParent myInboxID accepteeDB)
|
||||
runExceptT (Right . Right . Left <$> tryRemoveParent myInboxID accepteeDB) <|>
|
||||
runExceptT (Right . Right . Right <$> tryRemoveResource myInboxID accepteeDB)
|
||||
fromMaybeE
|
||||
maybeCollab
|
||||
"Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
|
||||
|
|
@ -1024,7 +1038,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
Left (Left collab) -> addCollab collab
|
||||
Left (Right resource) -> addResource resource
|
||||
Right (Left cp) -> addChildParent cp
|
||||
Right (Right parent) -> removeParent parent
|
||||
Right (Right (Left parent)) -> removeParent parent
|
||||
Right (Right (Right resource)) -> removeResource resource
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -1247,6 +1262,23 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
lift $ MaybeT $ getValBy $ UniqueEffortThemGestureRemoteAdd remoteActivityID
|
||||
tryAddResourcePassive' themID
|
||||
|
||||
tryRemoveResource' itemID = do
|
||||
EffortRemove sendID _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueEffortRemove itemID
|
||||
EffortUsSendDelegator effortID grantID <- lift $ lift $ getJust sendID
|
||||
lift $ verifyEffortHolder effortID
|
||||
topic <- lift . lift $ getEffortTopic effortID
|
||||
return (effortID, sendID, grantID, topic)
|
||||
|
||||
tryRemoveResource inboxID (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
InboxItemLocal _ _ i <-
|
||||
lift $ MaybeT $ getValBy $ UniqueInboxItemLocal inboxID itemID
|
||||
tryRemoveResource' i
|
||||
tryRemoveResource inboxID (Right remoteActivityID) = do
|
||||
InboxItemRemote _ _ i <-
|
||||
lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
|
||||
tryRemoveResource' i
|
||||
|
||||
componentIsAuthor ident =
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (resourceToActor . componentResource . snd) snd ident
|
||||
|
|
@ -2199,6 +2231,216 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
removeResource (effortID, sendID, grantID, resource) = do
|
||||
|
||||
topic <-
|
||||
lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) resource
|
||||
|
||||
-- Verify the sender is the topic
|
||||
unless (theyIsAuthor' topic) $
|
||||
throwE "The Accept isn't by the to-be-removed resource"
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(group, actorRecip) <- lift $ do
|
||||
p <- getJust groupID
|
||||
(p,) <$> getJust (groupActor p)
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
lift $ for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> 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 resource of
|
||||
Left (localID, _) -> do
|
||||
acceptID <- getKeyByJust $ UniqueEffortThemAcceptLocal localID
|
||||
deleteWhere [EffortThemDelegateLocalEffort ==. acceptID]
|
||||
delete acceptID
|
||||
Right (remoteID, _) -> do
|
||||
acceptID <- getKeyByJust $ UniqueEffortThemAcceptRemote remoteID
|
||||
deleteWhere [EffortThemDelegateRemoteEffort ==. acceptID]
|
||||
delete acceptID
|
||||
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 resource 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, _, _, _) <- prepareMainRevoke (bimap snd snd topic) 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
|
||||
resource <- do
|
||||
p <- getDestTopic destID
|
||||
bitraverse
|
||||
(\case
|
||||
Right j -> pure $ LocalActorGroup j
|
||||
Left _ -> error "I'm a group but I have a resource who is a Project"
|
||||
)
|
||||
pure
|
||||
(bimap snd snd p)
|
||||
return (resource, 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 "[Remove-Resource mode] Deleted the Resource/Effort, forwarded Accept, sent Revokes"
|
||||
|
||||
where
|
||||
|
||||
prepareMainRevoke resource grantID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
recipHash <- encodeKeyHashid groupID
|
||||
let topicByHash = LocalActorGroup recipHash
|
||||
|
||||
resourceHash <- bitraverse hashLocalResource pure resource
|
||||
|
||||
audRemover <- lift $ makeAudSenderOnly authorIdMsig
|
||||
audResource <-
|
||||
case resourceHash of
|
||||
Left lr ->
|
||||
let la = resourceToActor lr
|
||||
in pure $ AudLocal [la] [localActorFollowers la]
|
||||
Right actorID -> do
|
||||
actor <- getJust actorID
|
||||
ObjURI h lu <- getRemoteActorURI actor
|
||||
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
|
||||
let audMe = AudLocal [] [localActorFollowers topicByHash]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audRemover, audResource, audMe]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
||||
let uRemove = AP.acceptObject accept
|
||||
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
|
||||
|
||||
let uRemove = AP.acceptObject accept
|
||||
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: Someone has created a group with my ID URI
|
||||
-- Behavior:
|
||||
-- * Verify I'm in a just-been-created state
|
||||
|
|
|
|||
Loading…
Reference in a new issue