S2S: Group: Port Revoke handler from Project
This commit is contained in:
Pere Lev
parent
1e69a6e952
commit
6cb1c11141
1 changed files with 361 additions and 0 deletions
|
|
@ -3832,6 +3832,366 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do
|
|||
Just inboxItemID ->
|
||||
doneDB inboxItemID "[Child-passive] Saw the removal attempt, just waiting for the Revoke"
|
||||
|
||||
-- Meaning: An actor is revoking Grant activities
|
||||
-- Behavior:
|
||||
-- * For each revoked activity:
|
||||
-- * If it's a child revoking a delegator-Grant it gave me:
|
||||
-- * Delete the whole Dest record
|
||||
-- * Forward the Revoke to my followers
|
||||
-- * Send Accept to child+followers & my followers
|
||||
-- * If it's a parent revoking a Grant it had extended to me:
|
||||
-- * Delete that extension from my Source record
|
||||
-- * For each further extension I did on that Grant (to a
|
||||
-- child/collab), send a Revoke
|
||||
groupRevoke
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
-> Verse
|
||||
-> AP.Revoke URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest)) = do
|
||||
|
||||
ObjURI h _ <- lift $ getActorURI authorIdMsig
|
||||
parseRevoked <- do
|
||||
hl <- hostIsLocal h
|
||||
return $
|
||||
\ lu ->
|
||||
if hl
|
||||
then
|
||||
Left . (\ (a, _, i) -> (a, i)) <$>
|
||||
parseLocalActivityURI' lu
|
||||
else pure $ Right lu
|
||||
revokedFirst <- parseRevoked luFirst
|
||||
revokedRest <- traverse parseRevoked lusRest
|
||||
|
||||
mode <- withDBExcept $ do
|
||||
|
||||
revokedFirstDB <- do
|
||||
a <- getActivity $ second (ObjURI h) revokedFirst
|
||||
fromMaybeE a "Can't find revoked in DB"
|
||||
|
||||
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
||||
maybeMode <-
|
||||
ExceptT $ fmap adapt $ runMaybeT $
|
||||
runExceptT (Left <$> tryChild revokedFirstDB) <|>
|
||||
runExceptT (Right <$> tryParent 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
|
||||
|
||||
where
|
||||
|
||||
verifyDestHolder :: DestId -> MaybeT ActDB ()
|
||||
verifyDestHolder destID = do
|
||||
DestHolderGroup _ j <- MaybeT $ getValBy $ UniqueDestHolderGroup destID
|
||||
guard $ j == groupID
|
||||
|
||||
tryChild' usAcceptID send = do
|
||||
DestUsAccept destID _ <- lift $ lift $ getJust usAcceptID
|
||||
lift $ verifyDestHolder destID
|
||||
topic <- do
|
||||
t <- lift . lift $ getDestTopic destID
|
||||
bitraverse
|
||||
(\ (l, k) ->
|
||||
case k of
|
||||
Right j -> pure (l, j)
|
||||
Left _ -> error "Group Dest topic is a Project, impossible"
|
||||
)
|
||||
pure
|
||||
t
|
||||
return (destID, usAcceptID, topic, send)
|
||||
|
||||
tryChild (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
Entity sendID (DestThemSendDelegatorLocal usAcceptID _localID _) <-
|
||||
lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorLocalGrant itemID
|
||||
tryChild' usAcceptID (Left sendID) --(Left localID)
|
||||
tryChild (Right remoteActivityID) = do
|
||||
Entity sendID (DestThemSendDelegatorRemote usAcceptID _remoteID _) <-
|
||||
lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorRemoteGrant remoteActivityID
|
||||
tryChild' usAcceptID (Right sendID) --(Right remoteID)
|
||||
|
||||
verifySourceHolder :: SourceId -> MaybeT ActDB ()
|
||||
verifySourceHolder sourceID = do
|
||||
SourceHolderGroup _ j <- MaybeT $ getValBy $ UniqueSourceHolderGroup sourceID
|
||||
guard $ j == groupID
|
||||
|
||||
tryParent' sourceID child = do
|
||||
lift $ verifySourceHolder sourceID
|
||||
sendID <- lift $ MaybeT $ getKeyBy $ UniqueSourceUsSendDelegator sourceID
|
||||
return (sendID, child)
|
||||
|
||||
tryParent (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
Entity delegID (SourceThemDelegateLocal themAcceptID _) <-
|
||||
lift $ MaybeT $ getBy $ UniqueSourceThemDelegateLocal itemID
|
||||
SourceThemAcceptLocal topicID _ <- lift $ lift $ getJust themAcceptID
|
||||
SourceTopicLocal sourceID <- lift $ lift $ getJust topicID
|
||||
SourceTopicGroup _ _ j <- do
|
||||
mj <- lift $ lift $ getValBy $ UniqueSourceTopicGroupTopic topicID
|
||||
fromMaybeE mj "The parent to whom this revoked Grant was sent isn't a Group"
|
||||
tryParent' sourceID $ Left (topicID, j, delegID, themAcceptID)
|
||||
tryParent (Right remoteActivityID) = do
|
||||
Entity delegID (SourceThemDelegateRemote themAcceptID _) <-
|
||||
lift $ MaybeT $ getBy $ UniqueSourceThemDelegateRemote remoteActivityID
|
||||
SourceThemAcceptRemote topicID _ <- lift $ lift $ getJust themAcceptID
|
||||
SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID
|
||||
tryParent' sourceID $ Right (topicID, actorID, delegID, themAcceptID)
|
||||
|
||||
revokeChild revokedRest (destID, usAcceptID, child, send) = do
|
||||
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
unless (author == bimap (LocalActorGroup . snd) snd child) $
|
||||
throwE "Sender isn't the child Group the revoked Grant came from"
|
||||
|
||||
unless (null revokedRest) $
|
||||
throwE "Child revoking the delegator-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
|
||||
|
||||
maybeStartID <- getKeyBy $ UniqueDestUsStart usAcceptID
|
||||
|
||||
-- Delete uses of this Dest from my Effort records
|
||||
--for_ maybeStartID $ \ destStartID ->
|
||||
-- deleteWhere [ComponentGatherChild ==. destStartID]
|
||||
|
||||
-- Delete uses of this Dest from my Source records
|
||||
for_ maybeStartID $ \ destStartID -> do
|
||||
gatherIDs <- selectKeysList [SourceUsGatherDest ==. destStartID] []
|
||||
deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
|
||||
deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
|
||||
deleteWhere [SourceUsGatherId <-. gatherIDs]
|
||||
|
||||
-- Delete the whole Dest record
|
||||
for_ maybeStartID delete
|
||||
case send of
|
||||
Left sendID -> delete sendID
|
||||
Right sendID -> delete sendID
|
||||
origin <-
|
||||
requireEitherAlt
|
||||
(getKeyBy $ UniqueDestOriginUs destID)
|
||||
(getKeyBy $ UniqueDestOriginThem destID)
|
||||
"Neither us nor them"
|
||||
"Both us and them"
|
||||
deleteBy $ UniqueDestUsGestureLocal destID
|
||||
deleteBy $ UniqueDestUsGestureRemote destID
|
||||
case origin of
|
||||
Left usID -> delete usID
|
||||
Right themID -> do
|
||||
deleteBy $ UniqueDestThemAcceptLocal themID
|
||||
deleteBy $ UniqueDestThemAcceptRemote themID
|
||||
deleteBy $ UniqueDestThemGestureLocal themID
|
||||
deleteBy $ UniqueDestThemGestureRemote themID
|
||||
delete themID
|
||||
delete usAcceptID
|
||||
case child of
|
||||
Left (l, _j) -> do
|
||||
deleteBy $ UniqueDestTopicGroupTopic l
|
||||
delete l
|
||||
Right (r, _) -> delete r
|
||||
deleteBy $ UniqueDestHolderGroup destID
|
||||
delete destID
|
||||
|
||||
-- Prepare forwarding Remove to my followers
|
||||
sieve <- lift $ do
|
||||
topicHash <- encodeKeyHashid groupID
|
||||
let topicByHash =
|
||||
LocalActorGroup topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
|
||||
-- Prepare Accept activity
|
||||
accept@(actionAccept, _, _, _) <- prepareAccept
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
_luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
|
||||
|
||||
return (groupActor group, sieve, acceptID, accept, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
|
||||
let topicByID = LocalActorGroup groupID
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
lift $
|
||||
sendActivity
|
||||
topicByID topicActorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
doneDB inboxItemID "Deleted the Child/Dest, forwarded Revoke, sent Accept"
|
||||
|
||||
where
|
||||
|
||||
prepareAccept = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audChild <- makeAudSenderWithFollowers authorIdMsig
|
||||
audMe <-
|
||||
AudLocal [] . pure . LocalStageGroupFollowers <$>
|
||||
encodeKeyHashid groupID
|
||||
uRevoke <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audChild, audMe]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uRevoke]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uRevoke
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
revokeParent revokedRest (sendID, parent) = do
|
||||
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
unless (author == bimap (LocalActorGroup . view _2) (view _2) parent) $
|
||||
throwE "Sender isn't the parent Group the revoked Grant came from"
|
||||
|
||||
unless (null revokedRest) $
|
||||
throwE "Parent 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
|
||||
gatherIDs <-
|
||||
case parent of
|
||||
Left (_, _, delegID, _) ->
|
||||
map (sourceUsGatherFromLocalGather . entityVal) <$>
|
||||
selectList [SourceUsGatherFromLocalFrom ==. delegID] []
|
||||
Right (_, _, delegID, _) ->
|
||||
map (sourceUsGatherFromRemoteGather . entityVal) <$>
|
||||
selectList [SourceUsGatherFromRemoteFrom ==. delegID] []
|
||||
gathers <- selectList [SourceUsGatherId <-. gatherIDs] []
|
||||
leafIDs <-
|
||||
case parent of
|
||||
Left (_, _, delegID, _) ->
|
||||
map (sourceUsLeafFromLocalLeaf . entityVal) <$>
|
||||
selectList [SourceUsLeafFromLocalFrom ==. delegID] []
|
||||
Right (_, _, delegID, _) ->
|
||||
map (sourceUsLeafFromRemoteLeaf . entityVal) <$>
|
||||
selectList [SourceUsLeafFromRemoteFrom ==. delegID] []
|
||||
leafs <- selectList [SourceUsLeafId <-. leafIDs] []
|
||||
|
||||
-- Delete the records of these extensions
|
||||
deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
|
||||
deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
|
||||
deleteWhere [SourceUsGatherId <-. gatherIDs]
|
||||
deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs]
|
||||
deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs]
|
||||
deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs]
|
||||
deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs]
|
||||
deleteWhere [SourceUsLeafId <-. leafIDs]
|
||||
case parent of
|
||||
Left (_, _, delegID, _) -> delete delegID
|
||||
Right (_, _, delegID, _) -> delete delegID
|
||||
|
||||
-- Prepare and insert Revokes on all the extension-Grants
|
||||
revokesG <- for gathers $ \ (Entity _ (SourceUsGather _ startID grantID)) -> do
|
||||
DestUsStart acceptID _ <- getJust startID
|
||||
DestUsAccept destID _ <- getJust acceptID
|
||||
parent <- do
|
||||
p <- getDestTopic destID
|
||||
bitraverse
|
||||
(\case
|
||||
Right j -> pure $ LocalActorGroup j
|
||||
Left _ -> error "I'm a group but I have a parent who is a Project"
|
||||
)
|
||||
pure
|
||||
(bimap snd snd p)
|
||||
return (parent, grantID)
|
||||
revokesL <- for leafs $ \ (Entity _ (SourceUsLeaf _ enableID grantID)) -> do
|
||||
CollabEnable collabID _ <- getJust enableID
|
||||
recip <- getCollabRecip collabID
|
||||
return
|
||||
( bimap
|
||||
(LocalActorPerson . collabRecipLocalPerson . entityVal)
|
||||
(collabRecipRemoteActor . entityVal)
|
||||
recip
|
||||
, grantID
|
||||
)
|
||||
revokes <- for (revokesG ++ 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 SourceThemDelegate* 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:
|
||||
|
|
@ -3967,6 +4327,7 @@ groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
|
|||
AP.JoinActivity join -> groupJoin now groupID verse join
|
||||
AP.RejectActivity reject -> groupReject now groupID verse reject
|
||||
AP.RemoveActivity remove -> groupRemove now groupID verse remove
|
||||
AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke
|
||||
AP.UndoActivity undo -> groupUndo now groupID verse undo
|
||||
_ -> throwE "Unsupported activity type for Group"
|
||||
groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"
|
||||
|
|
|
|||
Loading…
Reference in a new issue