S2S: Group: Revoke: Implement resource mode
This commit is contained in:
Pere Lev
parent
4d37d1293a
commit
5d88036fc3
1 changed files with 170 additions and 2 deletions
|
|
@ -5286,6 +5286,10 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do
|
|||
-- * Delete that extension from my Source record
|
||||
-- * For each further extension I did on that Grant (to a
|
||||
-- child/collab), send a Revoke
|
||||
-- * If it's a resource revoking a Grant it had extended to me:
|
||||
-- * Delete that extension from my Effort record
|
||||
-- * For each further extension I did on that Grant (to a
|
||||
-- child/collab), send a Revoke
|
||||
groupRevoke
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
|
|
@ -5317,14 +5321,16 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest
|
|||
maybeMode <-
|
||||
ExceptT $ fmap adapt $ runMaybeT $
|
||||
runExceptT (Left <$> tryChild revokedFirstDB) <|>
|
||||
runExceptT (Right <$> tryParent revokedFirstDB)
|
||||
runExceptT (Right . Left <$> tryParent revokedFirstDB) <|>
|
||||
runExceptT (Right . Right <$> tryResource revokedFirstDB)
|
||||
fromMaybeE
|
||||
maybeMode
|
||||
"Revoked activity isn't a relevant Grant I'm aware of"
|
||||
|
||||
case mode of
|
||||
Left p -> revokeChild revokedRest p
|
||||
Right c -> revokeParent revokedRest c
|
||||
Right (Left c) -> revokeParent revokedRest c
|
||||
Right (Right r) -> revokeResource revokedRest r
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -5383,6 +5389,29 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest
|
|||
SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID
|
||||
tryParent' sourceID $ Right (topicID, actorID, delegID, themAcceptID)
|
||||
|
||||
verifyEffortHolder :: EffortId -> MaybeT ActDB ()
|
||||
verifyEffortHolder effortID = do
|
||||
Effort _ g <- lift $ getJust effortID
|
||||
guard $ g == groupID
|
||||
|
||||
tryResource' effortID resource = do
|
||||
lift $ verifyEffortHolder effortID
|
||||
sendID <- lift $ MaybeT $ getKeyBy $ UniqueEffortUsSendDelegator effortID
|
||||
return (sendID, resource)
|
||||
|
||||
tryResource (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
Entity delegID (EffortThemDelegateLocal themAcceptID _) <-
|
||||
lift $ MaybeT $ getBy $ UniqueEffortThemDelegateLocal itemID
|
||||
EffortThemAcceptLocal topicID _ <- lift $ lift $ getJust themAcceptID
|
||||
EffortTopicLocal effortID r <- lift $ lift $ getJust topicID
|
||||
tryResource' effortID $ Left (topicID, r, delegID, themAcceptID)
|
||||
tryResource (Right remoteActivityID) = do
|
||||
Entity delegID (EffortThemDelegateRemote themAcceptID _) <-
|
||||
lift $ MaybeT $ getBy $ UniqueEffortThemDelegateRemote remoteActivityID
|
||||
EffortThemAcceptRemote topicID _ <- lift $ lift $ getJust themAcceptID
|
||||
EffortTopicRemote effortID actorID <- lift $ lift $ getJust topicID
|
||||
tryResource' effortID $ Right (topicID, actorID, delegID, themAcceptID)
|
||||
|
||||
revokeChild revokedRest (destID, usAcceptID, child, send) = do
|
||||
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
|
|
@ -5635,6 +5664,145 @@ groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
revokeResource revokedRest (sendID, resource) = do
|
||||
|
||||
resource' <-
|
||||
lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) resource
|
||||
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
unless (author == bimap (resourceToActor . view _2) (view _2) resource') $
|
||||
throwE "Sender isn't the resource the revoked Grant came from"
|
||||
|
||||
unless (null revokedRest) $
|
||||
throwE "Resource revoking the start/extension-Grant and something more"
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(group, actorRecip) <- lift $ do
|
||||
p <- getJust groupID
|
||||
(p,) <$> getJust (groupActor p)
|
||||
|
||||
maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do
|
||||
|
||||
-- Collect the extensions I'll need to revoke
|
||||
distributeIDs <-
|
||||
case resource of
|
||||
Left (_, _, delegID, _) ->
|
||||
map (effortUsDistributeFromLocalDistribute . entityVal) <$>
|
||||
selectList [EffortUsDistributeFromLocalFrom ==. delegID] []
|
||||
Right (_, _, delegID, _) ->
|
||||
map (effortUsDistributeFromRemoteDistribute . entityVal) <$>
|
||||
selectList [EffortUsDistributeFromRemoteFrom ==. delegID] []
|
||||
distributes <- selectList [EffortUsDistributeId <-. distributeIDs] []
|
||||
leafIDs <-
|
||||
case resource of
|
||||
Left (_, _, delegID, _) ->
|
||||
map (effortUsLeafFromLocalLeaf . entityVal) <$>
|
||||
selectList [EffortUsLeafFromLocalFrom ==. delegID] []
|
||||
Right (_, _, delegID, _) ->
|
||||
map (effortUsLeafFromRemoteLeaf . entityVal) <$>
|
||||
selectList [EffortUsLeafFromRemoteFrom ==. delegID] []
|
||||
leafs <- selectList [EffortUsLeafId <-. leafIDs] []
|
||||
|
||||
-- Delete the records of these extensions
|
||||
deleteWhere [EffortUsDistributeFromLocalDistribute <-. distributeIDs]
|
||||
deleteWhere [EffortUsDistributeFromRemoteDistribute <-. distributeIDs]
|
||||
deleteWhere [EffortUsDistributeId <-. distributeIDs]
|
||||
deleteWhere [EffortUsLeafFromLocalLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafFromRemoteLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafToLocalLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafToRemoteLeaf <-. leafIDs]
|
||||
deleteWhere [EffortUsLeafId <-. leafIDs]
|
||||
case resource of
|
||||
Left (_, _, delegID, _) -> delete delegID
|
||||
Right (_, _, delegID, _) -> delete delegID
|
||||
|
||||
-- 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, revokes, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, revokes, inboxItemID) -> do
|
||||
let topicByID = LocalActorGroup groupID
|
||||
lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
|
||||
sendActivity
|
||||
topicByID topicActorID localRecipsExt
|
||||
remoteRecipsExt fwdHostsExt extID actionExt
|
||||
doneDB inboxItemID "Deleted the EffortThemDelegate* record, sent Revokes"
|
||||
|
||||
where
|
||||
|
||||
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
|
||||
|
||||
uRevoke <- 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 = [uRevoke]
|
||||
, AP.actionSpecific = AP.RevokeActivity AP.Revoke
|
||||
{ AP.revokeObject = luGrant :| []
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor is undoing some previous action
|
||||
-- Behavior:
|
||||
-- * If they're undoing their Following of me:
|
||||
|
|
|
|||
Loading…
Reference in a new issue